Réseaux linéaires symétriques dans le disque hyperbolique

Pierre Albarède

sep. 2010

http://pierre.albarede.free.fr
http://listes.ujf-grenoble.fr/wws/info/groumf

Prologue

Les entrées-sorties ne sont que des images.

SetDirectory@ToFileName[ParentDirectory@NotebookDirectory[],"image"];

Remove@"Global`*"

(*BeginPackage@"hyperbolicdisk`";*)

Les symboles publics doivent être utilisés ici, typiquement, en définissant un message d'usage.

(*intersection::usage=*)

(*Begin@"`Private`";*)

Bibliographie

Un dessin trouvé sur le site de Donald Knuth, http://www-cs-faculty.stanford.edu/~uno/.  Partie significative hors du cercle, visible grâce à peut-être un petit bug de Mathematica !

Import@"Knuth's knots.pdf"

http://mathworld.wolfram.com/PoincareHyperbolicDisk.html
http://numb3rs.wolfram.com/418/
http://www.cabri.net/abracadabri/GeoNonE/GeoHyper/HDroite/HDroite1.htm
http://www.maths.ac-aix-marseille.fr/debart/ts/inversion_cercles.html#ch4

http://en.wikipedia.org/wiki/Unit_disk
http://en.wikipedia.org/wiki/Poincar%C3%A9_disk_model
http://en.wikipedia.org/wiki/Uniform_tilings_in_hyperbolic_plane
http://en.wikipedia.org/wiki/Poincar%C3%A9_half-plane_model

http://www.plunk.org/~hatch/HyperbolicTesselations/
http://aleph0.clarku.edu/~djoyce/poincare/PoincareApplet.html
http://www.ics.uci.edu/~eppstein/junkyard/hypertile.html

http://www.josleys.com/show_gallery.php?galid=325
http://www.ultrafractal.com/
http://pierre.albarede.free.fr/structure/pavage.jpg
http://pierre.albarede.free.fr/construction%20filaire/index.html

Eppstein, Anderson.
Mulak, Novaes.

Soury (Thomé), tome 3, texte 129, p. 2.

Import["Soury.gif"]

Outils généraux

Graphiques

Fenêtre carrée

Clear@square;
square[halfside_:1]:=Times[#,{#,#}&@{-1,1}]&@halfside

square@1.5

Graphics[Circle[],PlotRange->square[],ImageSize->Small]

Teinte

Deux couleurs successives ne doivent pas être trop voisines, s'il n'y a pas assez de couleurs, alors répéter périodiquement la palette.

Clear@color;
color@p_Integer:=Part[#,1+Mod[p-1,Length@#]]&[Hue/@{.1,.17,.3,.5,.7,.8,0.}]

color@1

color@6

color@7

color@8

color@9

With[{p=25},Map[{color@#,Circle[{#,0},.5],Text[Style[#,FontSize->Scaled[.5/p]],{#,0}]}&,Range@p]]
Graphics@%

ClearAll@colorlegend;

Options@colorlegend={ImageSize->Medium};

colorlegend[p_Integer,shift_Integer:0,option___Rule]:=Graphics[Map[{color@#,Circle[{#,0},.5],Text[Style[#,FontSize->Scaled[.8/Length@Range@p]],{#,0}]}&,shift+Range@p],option,Sequence@@Options@colorlegend]

colorlegend@3

colorlegend[5,2]

colorlegend[4,0]

colorlegend[8,ImageSize->Small]

colorlegend@28

Listes

Unicité

ClearAll@only;

only::usage="only@list gives, if possible, only element of list, else wraps.";

only@_@x_:=x

only@{}
only@{1}
only@{1,2}

only@Point@{x,y}

Créateur, accesseur ou destructeur d'objet coloré

ClearAll@colorize;

colorize::usage="colorize[list,shift] maps variable color at first list level, with optional shift (default 0).";

colorize[list1_List,shift_Integer:0]:=MapIndexed[{color[shift+only@#2],#1}&,list1]

colorize[#,1]&@{{Circle[{0,1.792`},1.487`],Circle[{-1.704`,0.554`},1.487`],Circle[{-1.053`,-1.45`},1.487`],Circle[{1.053`,-1.45`},1.487`],Circle[{1.704`,0.554`},1.487`]},{Circle[{-0.852`,1.173`},1.049`],Circle[{-1.379`,-0.448`},1.049`],Circle[{0,-1.45`},1.049`],Circle[{1.379`,-0.448`},1.049`],Circle[{0.852`,1.173`},1.049`]},{{Circle[{-0.208`,1.173`},0.647`],Circle[{0.208`,1.173`},0.647`]},{Circle[{-1.18`,0.164`},0.647`],Circle[{-1.051`,0.56`},0.647`]},{Circle[{-0.521`,-1.071`},0.647`],Circle[{-0.858`,-0.826`},0.647`]},{Circle[{0.858`,-0.826`},0.647`],Circle[{0.521`,-1.071`},0.647`]},{Circle[{1.051`,0.56`},0.647`],Circle[{1.18`,0.164`},0.647`]}},{{Circle[{-0.724`,0.798`},0.401`],Circle[{-0.535`,0.935`},0.401`]},{Circle[{-0.983`,-0.442`},0.401`],Circle[{-1.055`,-0.22`},0.401`]},{Circle[{0.117`,-1.071`},0.401`],Circle[{-0.117`,-1.071`},0.401`]},{Circle[{1.055`,-0.22`},0.401`],Circle[{0.983`,-0.442`},0.401`]},{Circle[{0.535`,0.935`},0.401`],Circle[{0.724`,0.798`},0.401`]}}}

{{First@#,1},Insert[#,2,2]}&/@{{1,3},{3,2,2},{4,2,2}}

Flatten[#,1]&@Outer[Extract,{#},{{First@#,1},Insert[#,2,2]}&/@{{1,3},{3,2,2},{4,2,2}},1,2]&@{{Hue[(1/10)],{Circle[{0,1.792`},1.487`],Circle[{-1.704`,0.554`},1.487`],Circle[{-1.053`,-1.45`},1.487`],Circle[{1.053`,-1.45`},1.487`],Circle[{1.704`,0.554`},1.487`]}},{Hue[(1/5)],{Circle[{-0.852`,1.173`},1.049`],Circle[{-1.379`,-0.448`},1.049`],Circle[{0,-1.45`},1.049`],Circle[{1.379`,-0.448`},1.049`],Circle[{0.852`,1.173`},1.049`]}},{Hue[(3/10)],{{Circle[{-0.208`,1.173`},0.647`],Circle[{0.208`,1.173`},0.647`]},{Circle[{-1.18`,0.164`},0.647`],Circle[{-1.051`,0.56`},0.647`]},{Circle[{-0.521`,-1.071`},0.647`],Circle[{-0.858`,-0.826`},0.647`]},{Circle[{0.858`,-0.826`},0.647`],Circle[{0.521`,-1.071`},0.647`]},{Circle[{1.051`,0.56`},0.647`],Circle[{1.18`,0.164`},0.647`]}}},{Hue[(1/2)],{{Circle[{-0.724`,0.798`},0.401`],Circle[{-0.535`,0.935`},0.401`]},{Circle[{-0.983`,-0.442`},0.401`],Circle[{-1.055`,-0.22`},0.401`]},{Circle[{0.117`,-1.071`},0.401`],Circle[{-0.117`,-1.071`},0.401`]},{Circle[{1.055`,-0.22`},0.401`],Circle[{0.983`,-0.442`},0.401`]},{Circle[{0.535`,0.935`},0.401`],Circle[{0.724`,0.798`},0.401`]}}}}

ClearAll@extractfromcolorized;

extractfromcolorized::usage="extractfromcolorized[list,position] extracts from colorized list as if not colorized.";

extractfromcolorized[list1_List,{}]:={}

extractfromcolorized[list1_List,position1:{_List..}]:=
Flatten[#,1]&@Outer[Extract[#1,{(*color*){First@#2,1},Insert[#2,2,2]}]&,{#1},#2,1,1]&[list1,position1]

extractfromcolorized[list1_List,position1:{_Integer...}]:=extractfromcolorized[list1,{position1}]

Scan[Print,{Sequence@@#,Graphics[Last@#,ImageSize->Small]}]&@{Graphics[#,ImageSize->Small],extractfromcolorized@##}&[{{Hue[(1/10)],{Circle[{0,1.792`},1.487`],Circle[{-1.704`,0.554`},1.487`],Circle[{-1.053`,-1.45`},1.487`],Circle[{1.053`,-1.45`},1.487`],Circle[{1.704`,0.554`},1.487`]}},{Hue[(1/5)],{Circle[{-0.852`,1.173`},1.049`],Circle[{-1.379`,-0.448`},1.049`],Circle[{0,-1.45`},1.049`],Circle[{1.379`,-0.448`},1.049`],Circle[{0.852`,1.173`},1.049`]}},{Hue[(3/10)],{{Circle[{-0.208`,1.173`},0.647`],Circle[{0.208`,1.173`},0.647`]},{Circle[{-1.18`,0.164`},0.647`],Circle[{-1.051`,0.56`},0.647`]},{Circle[{-0.521`,-1.071`},0.647`],Circle[{-0.858`,-0.826`},0.647`]},{Circle[{0.858`,-0.826`},0.647`],Circle[{0.521`,-1.071`},0.647`]},{Circle[{1.051`,0.56`},0.647`],Circle[{1.18`,0.164`},0.647`]}}},{Hue[(1/2)],{{Circle[{-0.724`,0.798`},0.401`],Circle[{-0.535`,0.935`},0.401`]},{Circle[{-0.983`,-0.442`},0.401`],Circle[{-1.055`,-0.22`},0.401`]},{Circle[{0.117`,-1.071`},0.401`],Circle[{-0.117`,-1.071`},0.401`]},{Circle[{1.055`,-0.22`},0.401`],Circle[{0.983`,-0.442`},0.401`]},{Circle[{0.535`,0.935`},0.401`],Circle[{0.724`,0.798`},0.401`]}}}},{{1,3},{3,2},{4,2,2}}]

extractfromcolorized[{{Hue[0.1`],{Circle[{-0.202`,1.177`},0.653`],Circle[{-0.529`,0.94`},0.404`],Circle[{-0.731`,0.793`},0.404`],Circle[{-1.057`,0.556`},0.653`],Line@{{0.588`,-0.809`},{-0.588`,0.809`}}}},{Hue[0.17`],{Circle[{-1.182`,0.172`},0.653`],Circle[{-1.057`,-0.212`},0.404`],Circle[{-0.98`,-0.45`},0.404`],Circle[{-0.855`,-0.834`},0.653`],Line[{{0.951`,0.309`},{-0.951`,-0.309`}}]}},{Hue[0.3`],{Circle[{-0.529`,-1.071`},0.653`],Circle[{-0.125`,-1.071`},0.404`],Circle[{0.125`,-1.071`},0.404`],Circle[{0.529`,-1.071`},0.653`],Line[{{0,1.`},{0,-1.`}}]}},{Hue[0.3`],{Circle[{0.855`,1.177`},1.057`],Circle[{0,1.799`},1.495`],Line[{{-0.588`,-0.809`},{0.588`,0.809`}}],Circle[{1.711`,0.556`},1.495`]}}},{2,3}]

extractfromcolorized[{{Hue[0.1`],{Circle[{-0.202`,1.177`},0.653`],Circle[{-0.529`,0.94`},0.404`],Circle[{-0.731`,0.793`},0.404`],Circle[{-1.057`,0.556`},0.653`],Line@{{0.588`,-0.809`},{-0.588`,0.809`}}}},{Hue[0.3`],{Circle[{0.855`,1.177`},1.057`],Circle[{0,1.799`},1.495`],Line[{{-0.588`,-0.809`},{0.588`,0.809`}}],Circle[{1.711`,0.556`},1.495`]}}},{{1,1},{2,-1}}]

extractfromcolorized[{{Hue[0.1`],{Circle[{-0.202`,1.177`},0.653`],Circle[{-0.529`,0.94`},0.404`],Circle[{-0.731`,0.793`},0.404`],Circle[{-1.057`,0.556`},0.653`],Line@{{0.588`,-0.809`},{-0.588`,0.809`}}}},{Hue[0.3`],{Circle[{0.855`,1.177`},1.057`],Circle[{0,1.799`},1.495`],Line[{{-0.588`,-0.809`},{0.588`,0.809`}}],Circle[{1.711`,0.556`},1.495`]}}},{}]

Clear@deletefromcolorized;

deletefromcolorized[list1_List,{}]:=list1

deletefromcolorized[list1_List,position1:{_List..}]:=Delete[list1,Insert[#,2,2]&/@position1]

deletefromcolorized[list1_List,position1:{_Integer..}]:=deletefromcolorized[list1,{position1}]

deletefromcolorized[{{Hue[0.1`],{Circle[{-0.202`,1.177`},0.653`],Circle[{-0.529`,0.94`},0.404`],Circle[{-0.731`,0.793`},0.404`],Circle[{-1.057`,0.556`},0.653`],Line@{{0.588`,-0.809`},{-0.588`,0.809`}}}},{Hue[0.3`],{Circle[{0.855`,1.177`},1.057`],Circle[{0,1.799`},1.495`],Line[{{-0.588`,-0.809`},{0.588`,0.809`}}],Circle[{1.711`,0.556`},1.495`]}}},{{1,1},{2,-1}}]

À faire : généraliser à Positon, MapAt, ReplacePart (voir documentation de Extract), modèle d'objet coloré.

Faire tourner une liste pour placer un élément d'une certaine forme en tête

Clear@linefirst;linefirst[list1_List]:=RotateLeft[#,Switch[#,{},0,_,First@#-1]&@Position[#,_Line]]&@list1

linefirst/@{{Circle[{-0.82`,0.71`},0.41`],Line@{{0.5`,-0.87`},{-0.5`,0.87`}},Circle[{-0.2`,1.06`},0.41`],Circle[{-0.41`,0.94`},0.24`],Circle[{-0.51`,0.88`},0.2`],Circle[{-0.61`,0.82`},0.24`]},{Circle[{-0.82`,0.71`},0.41`],Circle[{-0.2`,1.06`},0.41`],Circle[{-0.41`,0.94`},0.24`],Circle[{-0.51`,0.88`},0.2`],Circle[{-0.61`,0.82`},0.24`]},{Circle[{-0.82`,0.71`},0.41`],Line[{{0.5`,-0.87`},{-0.5`,0.87`}}],Circle[{-0.2`,1.06`},0.41`],Circle[{-0.41`,0.94`},0.24`],Line[{-0.51`,0.88`},_],Circle[{-0.61`,0.82`},0.24`]}}

Nombres

Précision et arrondi

Extrait de la documentation de Equal : "Approximate numbers with machine precision or higher are considered equal if they differ in at most their last seven binary digits (roughly their last two decimal digits). "

1.000001`3==1

1.000001`10==1

1.0000000000001==1

1.00000000000001==1

Precision@1.

Precision@1.0000000000000001

Precision@1.00000000000000001

N@MachinePrecision

Chop@{1. 10^-16,1. 10^-10,1. 10^-11}

precisions={PrecisionGoal->Infinity,AccuracyGoal->6,WorkingPrecision->10};

Pour ne pas avoir d'ennuis, ratisser large.

Clear@chop;chop@x_:=Chop[x,10 10^-AccuracyGoal/.precisions]

chop@{1. 10^-16,1. 10^-10,1. 10^-11,1. 10^-5,1. 10^-7}

Faire maigrir un tableau de nombres.

Clear@roundall;
roundall@n_Integer:=#/.x_Real:>1.Round[x, 10^-n ]&

Table[1.Log[i+j],{i,3},{j,4}]

roundall[2]@{{0.6931471805599453`,1.0986122886681098`,1.3862943611198906`,1.6094379124341003`},{1.0986122886681098`,1.3862943611198906`,1.6094379124341003`,1.791759469228055`},{1.3862943611198906`,1.6094379124341003`,1.791759469228055`,1.9459101490553132`}}

Rationalisation

Dénominateur non premier non trouvé si simplification.

With[{denominators={4,7}},TableForm[ {#,Cases[{Denominator@Rationalize@#1},Alternatives@@#2]&[#,denominators]}&/@{0.,1/4.,3/4.,1/2.,1./7,2./7,3./7,3./5,2./8}]]

With[{denominators={4,7}},TableForm[ {#,Transpose@{#2,#2/Denominator@Rationalize@#1}&[#,denominators]}&/@{0.,1/4.,3/4.,1/2.,1./7,2./7,3./7,3./5,2./8},TableDepth->2]]

With[{denominators={4,7}},TableForm[ {#,Cases[Transpose@{#2,#2/Denominator@Rationalize@#1},{y_,_Integer}:>y]&[#,denominators]}&/@{0.,1/4.,3/4.,1/2.,1./7,2./7,3./7,3./5,2./8},TableDepth->2]]

Précision mieux contrôlée.

With[{denominators={4,7}},TableForm[{#,Cases[#,{0,y_}:>y]&@Flatten[#,1]&@Outer[{chop[#-Round@#]&[#1 #2],#2}&,{#1},#2,1,1]&[#,denominators]}&/@{0.,1/4.,3/4.,1/2.,1./7,2./7,3./7,3./5,2./8},TableDepth->2]]

Clear@fraction;
fraction[x_Real,denominators:{_Integer..}]:=only@Cases[#,{0,y_}:>y]&@Flatten[#,1]&@Outer[{chop[#-Round@#]&[#1 #2],#2}&,{#1},#2,1,1]&[x,denominators]

With[{denominators={4,5,7}},TableForm[{#,fraction[#,denominators]}&/@{0.,1.,1/4.,3/4.,1/2.,1./7,2./7,3./7,3./5,2./8}]]

TableForm[{#,fraction[#,{1,2}]}&/@{1. 10^-10,-1. 10^-10,1+1. 10^-10,1-1. 10^-10,.5,-2. +10^-8,1/2.}]

TableForm[{#,fraction[#,{2}]}&/@{1. 10^-10,-1. 10^-10,1+1. 10^-10,1-1. 10^-10,.5,-2. 1+10^-8,1/2.}]

Congruence circulaire

θ=0 mod Pi ?

With[{θ=#},{θ,chop[Mod[θ+Pi/2,Pi]-Pi/2]==0}]&/@{0,Pi,Pi/2,-1. 10^-7,1. Pi+10^-7}

θ=Pi/2 mod Pi ?

With[{θ=#},{θ,chop[Mod[θ,Pi]-Pi/2]==0}]&/@{0,Pi/2,1. Pi,Pi/2+.0000000001-1. 10^-7,1. Pi+10^-7}

Les fonctions triognométriques ont les mêmes zéros qui sont bien plus familiers.

Plot[{Mod[θ+Pi/2,Pi]-Pi/2,Sin@θ},{θ,-2Pi,2Pi}]

Function[θ,Abs[Mod[θ+Pi/2,Pi]-Pi/2]]/@{Pi-1. 10^-7,Pi,Pi+1. 10^-7,Pi/2}

Plot[{Mod[θ,Pi]-Pi/2,Cos@θ},{θ,-2Pi,2Pi}]

Complexes

cartesian=Through[{Re,Im}@#]&;
complex=First@#+I Last@#&;

complex@{x,y}

Complex est un type numérique, à utiliser de préférence sur des nombres (Real, Integer, Rational).

Re[Complex@@{x,y}]

Argument à coupure mobile.

Clear@argcut;
argcut[c_,θ_]:=Arg[#1/(-E^(I#2))]+#2-Pi&[c,θ];

argcut[E^(I( -1)),Pi]

Arg[E^(I (-1))]

Manipulate[Plot[{Arg[E^(I θ)],argcut[E^(I θ),θ1]},{θ,0,2Pi}],{{θ1,Pi},0,2Pi}]

Arg@0==Indeterminate

Racines de l'unité.

Map[(E^(2I Pi/5#))&,Range@5-1]

Génléralisation fonctionnelle :

Map[Function[t,(E^(2I Pi/# t))],Range@#-1]&@5

λ-calcul :

(E^(2I Pi/#1#2))&@@#&/@Distribute[{{#},Range@#-1},List]&@5

ou

Flatten[#,1]&@Outer[(E^(2I Pi/#1#2))&,Sequence@@{{#},Range@#-1}]&@5

Division du cercle.

Clear@unitroots;
unitroots@n_Integer:=Flatten[#,1]&@Outer[(E^(2I Pi/#1#2))&,Sequence@@{{n},Range@n-1}]&@n

unitroots@1

unitroots@6

Graphics[{Circle[],Composition[Point,cartesian]/@unitroots@17},ImageSize->Small]

With[{n=5},{Arg/@unitroots[2n],(Range[2n]-1)Pi/n}]

Distance euclidienne

Norm@{x,y}

EuclideanDistance[{x1,y1},{x2,y2}]

Précision fausse !

With[{x1=-0.85543132194596481861659860551578575199`9.432857951541958,y1=1.17740021390597731146004760878972450511`9.50372714193449,x2=-0.85543132493218348327046418923939231794`9.547470161804235,y2=-0.83383945680131741706534557943707401297`9.445232325721285},(Print@clip[{Point/@#},Axes->True,Method->None,ImageSize->Small];FullForm[EuclideanDistance@@#])&@{{x1,y1},{x2,y2}}]

Clear@euclideannorm;
euclideannorm@{x_,y_}:=Sqrt[#.#]&@{x,y}

euclideannorm@{x,y}

Clear@euclideandistance;
euclideandistance[{x1_,y1_},{x2_,y2_}]:=euclideannorm[{x2,y2}-{x1,y1}]

euclideandistance[{x1,y1},{x2,y2}]

With[{x1=-0.85543132194596481861659860551578575199`9.432857951541958,y1=1.17740021390597731146004760878972450511`9.50372714193449,x2=-0.85543132493218348327046418923939231794`9.547470161804235,y2=-0.83383945680131741706534557943707401297`9.445232325721285},(Print@clip[{Point/@#},Axes->True,Method->None,ImageSize->Small];FullForm[euclideandistance@@#])&@{{x1,y1},{x2,y2}}]

Ensembles

ClearAll@sametest;

Attributes@sametest={Orderless};

sametest::usage="sametest[x1,x2] gives True if x1, x2 are identical according to chop with implicit precisions.";

sametest[x1_,x2_]:=If[NumericQ@x1,chop[x2-x1]===0,x1===x2]

sametest[f1_@x1__,f1_@x2__]:=If[Length@{x1}≠ Length@{x2},False,And@@MapThread[sametest,{{x1},{x2}}]]

sametest[Pi,Pi+.00000001]

sametest[f1@.3,f1@.30000000001]

sametest[f1[.3,Pi],f1[.30000000001,Pi,E]]

sametest[{x,.3},{x,.30000000001}]

sametest[x,x]

sametest[f1@x,x]

Union[{Pi,Pi+.00000001},SameTest->sametest]

Union[{{Line@{{0,-1.`},{0,1.`}},Circle[{0.8554313215843424`,1.1774002051369277`},1.05737126356073034911570351470012007686`10.],Circle[{0.20193994195696527`,1.177400205105374`},0.65349137954510133834802145144955297547`10.],Circle[{-0.20193994194496118`,1.1774002050858725`},0.65349137950625555721037147493056404957`10.],Circle[{-0.8554313213689392`,1.177400205054318`},1.05737126329447736377685606358275039081`10.]},{Line[{{0.5877852522935606`,-0.8090169943741573`},{-0.5877852522935606`,0.8090169943741573`}}],Circle[{-0.20193994196446335`,1.1774002050778387`},0.65349137949780807819012239797587906272`10.],Circle[{-0.5286856317154618`,0.9400055656306235`},0.40387988387505075685914137402358122658`10.],Circle[{-0.7306255736512977`,0.7932876097108894`},0.40387988386908409132419450786974666817`10.],Circle[{-1.0573712633770236`,0.5558929702820327`},0.65349137945691833161413338039989230632`10.]},{Line[{{0,-1.`},{0,1.`}}],Circle[{0.8554313215020641`,1.1774002051053722`},1.05737126345902891948326439294241385798`10.],Circle[{0.20193994194496115`,1.1774002050858723`},0.65349137950625550409626392739830316996`10.],Circle[{-0.20193994193754225`,1.1774002050738197`},0.6534913794822473741452996632278477215`10.],Circle[{-0.8554313213689387`,1.1774002050543175`},1.05737126329447672416169402949779481966`10.]},{Line[{{0,-1.`},{0,1.`}}],Circle[{0.8554313214512159`,1.1774002050858723`},1.05737126339617698424633868797768075599`10.],Circle[{0.2019399419375424`,1.1774002050738201`},0.65349137948224754188214232958837387067`10.],Circle[{-0.201939941932957`,1.1774002050663706`},0.65349137946740928725765502611547875733`10.],Circle[{-0.8554313213689396`,1.1774002050543184`},1.05737126329447796308073413854538961671`10.]}},SameTest->sametest]

ClearAll@apart;

apart::usage="apart[list1,list2] gives {list1∖list1⋂list2,list2}";

apart[list1_List,list2_List]:={Complement[#1,Intersection[#1,#2,SameTest->sametest],SameTest->sametest],Union[#2,SameTest->sametest]}&[list1,list2]

apart[{x1,x2,x3,x4},{y1,x3,y2,x2,y3}]

apart[{x1,x1,x2,x3,x4},{y1,x3,y2,x2,x2,x2,y3}]

apart[{x1,x2,x3,1.00000000001},{x1,x2,x3,1}]

apart[{x1,x2,x3,1},{x1,x2,x3,1.00000000001}]

Outils de géométrie

Pseudo-ordres circulaires

Radial

Deux points distincts peuvent être à même distance du centre.  Relation d'ordre modulo rotation.

closerQ=euclideannorm@#1≤euclideannorm@#2&;

closerQ[{x1,y1},{x2,y2}]

Sort[{{0,1},{.5,5.},{.5,.5}},closerQ]

Circonférentiel

Clear@sortdet;
sortdet[list1_List,pointfunction_:Identity]:=Sort[#,Det[pointfunction/@{#1,#2}]≥0&]&@list1;

sortdet[{{0,1},{.1,1}}]

Sur un cercle, relation non-transitive,

sortdet[cartesian/@unitroots@3]

sortdet@{{1,0},{-(1/2),-((Sqrt[3])/2)}}

non anti-symétrique,

sortdet@{{1,0},{-1,0}}

sortdet@{{-1,0},{1,0}}

mais, sur un demi-cercle ouvert, relation d'ordre total.

Sort a besoin de beaucoup moins qu'une relation d'ordre.

GraphicsGrid[List@Graphics@{Arrowheads@Medium,Arrow@sortdet@#}&/@Permutations[cartesian/@unitroots@3]]

GraphicsGrid[List@Graphics@{Arrowheads@Medium,Arrow@sortdet@#}&/@Permutations@{{1,0},{0,1},{-1,0}}]

GraphicsGrid[List@Graphics@{Arrowheads@Medium,Arrow@sortdet@#}&/@Permutations@{{0,1},{1,0},{#,#}&@Sqrt@2/2}]

Tri de cercle selon le centre.

First@Circle@{-.5,.5}

sortdet[{Circle@{-.5,.5},Circle@{.5,.5}},First]

sortdet[{Circle[{-.5,.5},.3],Circle[{.5,.5}]},First]

sortdet[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},First]

sortdet[{Circle[pt1,r1],Circle[pt2,r2]},First]

Symétries

Miroir sur un diamètre

Clear@pointmirror;
pointmirror[pt_List,θ_?NumericQ]:=cartesian[Conjugate[((complex@pt)/(E^(I θ)))]E^(I θ)]

pointmirror[{1,10},θ]

With[{x=.3,y=.8},Manipulate[Graphics[{PointSize->.04,Point@{x,y},Line@{{0,0},cartesian[E^(I θ)]},Red,Point@pointmirror[{x,y},θ]},ImageSize->Small,PlotRange->{{-1,1},{0,1}}],{{θ,Pi/2},0,Pi}]]

With[{pt={.3,.8},θ=Pi/2+.2},Point@pointmirror[pt,θ]]

Clear@mirrororbit;
mirrororbit@θ_:=#/.{Circle[pt_,r___]:>{Circle[pt,r],Circle[pointmirror[pt,θ],r]},Point@pt_:>{Point@pt,Point@pointmirror[pt,θ]}}&

mirrororbit[θ]@Circle[{1,1}]

mirrororbit[Pi/2]@Circle[{1,1}]

Manipulate[Graphics[{Circle[],Riffle[Transpose@mirrororbit[θ]@{Circle[{.2,.4},.1],Point@{.8,.1}},{Red}]},Axes->True,ImageSize->Small],{θ,0,Pi/2}]

Rotation autour de l'origine

On pouvait espérer les nouvelles coordonnées mais non !

Rotate[Point[{1,0}],30Degree,{0,0}]

Rotation autour de l'origine.

Clear@pointrotate;
pointrotate[pt_List,θ_?NumericQ]:=cartesian[E^(I θ) complex@pt]

ComplexExpand[pointrotate[{x,y},Pi/2]]

With[{x=.4,y=.6},pointrotate[{x,y},Pi/2]]

Orbite d'une constellation = liste de points.

With[{n=5,pts={{.1,.8},{-.05,.75}}},(Print@Graphics[{Thick,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Line/@#];#)&@Outer[Composition[cartesian,Times],unitroots@n,complex/@pts]]

Clear@pointrotateorbit;
pointrotateorbit[pts:{_List..},n_Integer]:=Outer[Composition[cartesian,Times],unitroots@n,complex/@pts,1,1]

With[{n=5,pts={{.1,.8},{-.05,.75}}},(Print@Graphics[{Thick,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Line/@#];#)&@pointrotateorbit[pts,n]]

Faire tourner pour le que le premier point (de la constellation) soit aussi le premier circonférentiellement après θ arbitraire.

With[{n=5,pts={{.1,.8},{-.05,.75}},θ=Pi/2},(Print@Graphics[{Thick,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Line/@#];#)&@Transpose[RotateRight[#,Floor@chop@Divide[Arg@complex@First@pts-θ,2Pi/n]]&/@Transpose@pointrotateorbit[pts,n]]]

pointrotateorbit[pts:{_List..},n_Integer,θ_?NumericQ]:=Transpose[RotateRight[#,Floor@chop@Divide[Arg@complex@First@pts-θ,2Pi/n]]&/@Transpose@pointrotateorbit[pts,n]]

With[{n=5,pts={{.1,.8},{-.05,.75}},θ=Pi/2},(Print@Graphics[{Thick,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Line/@#];#)&@pointrotateorbit[pts,n,θ]]

Cas d'un seul point : syntaxe plus simple.

pointrotateorbit[{x_?AtomQ,y_?AtomQ},z___]:=only/@pointrotateorbit[{{x,y}},z]

With[{n=5,pt={.1,.8}},(Print@Graphics[{PointSize->.05,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Point/@#];#)&@pointrotateorbit[pt,n]]

With[{n=5,pt={.1,.8},θ=Pi/2},(Print@Graphics[{PointSize->.05,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Point/@#];#)&@pointrotateorbit[pt,n,θ]]

With[{n=5,θ=Pi/2,pt={10^-PrecisionGoal/.precisions,.8}},(Print@Graphics[{PointSize->.05,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Point/@#];#)&@pointrotateorbit[pt,n,θ]]

With[{n=5,θ=Pi/2,pt={10 10^-PrecisionGoal/.precisions,.8}},(Print@Graphics[{PointSize->.05,Red,First@#,Black,Sequence@@Rest@#},Axes->True,ImageSize->Small]&[Point/@#];#)&@pointrotateorbit[pt,n,θ]]

pointrotateorbit[{0,0},5]

pointrotateorbit[{-0.863876335634764`,1.1890237698905772`},5,Pi/2]

pointrotateorbit[{{-0.863876335634764`,1.1890237698905772`}},5,0]

With[{n=4},{Graphics[{Circle[],#},ImageSize->Small],#}&@Line@pointrotateorbit[{{-1,0},{1,0}},n]]

With[{n=4,θ=Pi/2},{Graphics[{Circle[],#},ImageSize->Small],#}&@Line@pointrotateorbit[{{-1,0},{1,0}},n,θ]]

With[{n=6,θ=Pi/2},(Print@Graphics[{Circle[],Line@#},ImageSize->Small];#)&@pointrotateorbit[{1,0},n,θ]]

Clear@rotateorbit;
rotateorbit[n_?NumericQ,θ___]:=#/.{Circle[pt_,r___]:>Map[Circle[#,r]&,pointrotateorbit[pt,n,θ]],Point@pt_:>Point/@pointrotateorbit[pt,n,θ],Line@pts_:>Line/@pointrotateorbit[pts,n,θ]}&

With[{n=3,θ=0},pointrotateorbit[{{-1,0},{1,0}},n,θ] ]

With[{n=3,θ=0},{Graphics[#,ImageSize->Small],#}&@rotateorbit[n,θ]@Line@{{-1,0},{1,.1},{1,0}} ]

With[{n=3},{Graphics[#,ImageSize->Small],#}&@rotateorbit[n]@Line@{{-1,0},{1,0}} ]

(Print@Graphics[#,ImageSize->Small];#)&@With[{n=5,c=-.3I},{Red,First@#,Black,Rest@#}&/@rotateorbit[n,Arg@c]@{Circle[{0,1}],Point@{.6,0}}]

Intersections

Vecteur tangent à une droite ou un cercle

Clear@tangent;
tangent[Line@{pt1_,pt2_},___]:=Normalize[pt2-pt1]
tangent[Circle[pt_,r___],Point@pt1_]/;Not@sametest[pt,pt1]:=Normalize@pointrotate[pt1-pt,Pi/2]

tangent@Line@{pt1,pt2}

tangent@Line@{{1,0},{0,1}}

tangent[Circle[],Point@{0,1}]

Si le point n'est pas sur le cercle, c'est son projeté orthogonal sur le cercle qui est le point de tangence.

tangent[Circle[],Point@{1,1}]

Normalize@pointrotate[{.1,.2},Pi/2]==tangent[Circle[],Point@{.1,.2}]

Angle d'intersection droite-cercle ou cercle-cercle

With[{θ=Pi/3},{clip@#,intersection@@#}&@{Line@{{0,0},cartesian[E^(I θ)]},Circle[{.5,.5},.5]}]

On suppose qu'il n'y a qu'une intersection dans le disque unité.

With[{pt1={0,0}},Manipulate[With[{pt2=cartesian[E^(I θ)],pt={.5,.5},r=.5},{clip@{##},Min[#,Pi-#]&@VectorAngle[tangent[#2,Point@First@intersection@##],tangent@#1]}&[Line@{pt1,pt2},Circle[pt,r]]],{θ,0,Pi/2}]]

Généraliser à intersection quelconque, avec tangent.

With[{pt1={0,0}},Manipulate[With[{pt2=cartesian[E^(I θ)],pt={.5,.5},r=.5},{clip@{##},Min[#,Pi-#]&@VectorAngle[tangent[#2,#3],tangent[#1,#3]]&[##,Point@First@intersection@##]}&[Line@{pt1,pt2},Circle[pt,r]]],{θ,0,Pi/2}]]

With[{pt1={.5,0},pt2={0,.5},r1=Sqrt@2/4},Manipulate[{clip@{##},Min[#,Pi-#]&@VectorAngle[tangent[#2,#3],tangent[#1,#3]]&[##,Point@First@intersection@##]}&[Circle[pt1,r1],Circle[pt2,r2]],{r2,r1+.0000001,1.3}]]

With[{pt1={.5,0},pt2={0,.5},r1=Sqrt@2/4},Manipulate[Flatten[#,1]&@Outer[tangent1[#2,#1]&,{Point@First@intersection@##},{##},1,1]&[Circle[pt1,r1],Circle[pt2,r2]],{r2,r1+.0000001,1.3}]]

With[{pt1={.5,0},pt2={0,.5},r1=Sqrt@2/4},Manipulate[{Graphics@{##},Min[#,Pi-#]&[VectorAngle@@Flatten[#,1]&@Outer[tangent[#2,#1]&,{Point@First@intersection@##},{##},1,1]]}&[Circle[pt1,r1],Circle[pt2,r2]],{r2,r1+.0000001,1.3}]]

With[{pt1={.5,0},pt2={0,.5},r1=Sqrt@2/4},With[{r2=r1+.0000001},{Circle[pt1,r1],Circle[pt2,r2]}]]

With[{θ=Pi/3},{Line@{{0,0},cartesian[E^(I θ)]},Circle[{.5,.5},.5]}]

Min[#,Pi-#]&[VectorAngle@@Flatten[#,1]&@Outer[tangent[#2,#1]&,{Point@First@intersection@##},{##},1,1]]&@@#&/@{{Circle[{0.5`,0},(1/(2 (Sqrt[2])))],Circle[{0,0.5`},0.35355349059327373`]},{Line[{{0,0},{(1/2),((Sqrt[3])/2)}}],Circle[{0.5`,0.5`},0.5`]}}

Min[#,Pi-#]&[VectorAngle@@Flatten[#,1]&@Outer[tangent[#2,#1]&,{Point@First@intersection@##},{##},1,1]]&[Circle[{0.5`,0},(1/(2 (Sqrt[2])))],Circle[{0,0.5`},0.35355349059327373`]]

Conserver l'intersection.

{Min[#,Pi-#],#2}&[VectorAngle@@Flatten[#,1]&@Outer[tangent[#2,#1]&,{Point@#2},#1,1,1],#2]&[{##},First@intersection@##]&[Circle[{0.5`,0},(1/(2 (Sqrt[2])))],Circle[{0,0.5`},0.35355349059327373`]]

Il n'y a au plus qu'une intersection dans le disque.

Clear@intersectionangle;
intersectionangle[lineorcircle:{Repeated[_Line|_Circle,{2}]},Point@pt_List]:=Min[#,Pi-#]&[VectorAngle@@Flatten[#,1]&@Outer[tangent[#2,#1]&,{Point@#2},#1,1,1]]&[lineorcircle,pt]

intersectionangle[{Circle[{.5,0},.5],Circle[{0,.5},.5]},Point[{0.`,0.`}]]

intersectionangle[#,Point@First[intersection@@#]]&@{Circle[{.5,0},.5],Circle[{0,.5},.5]}

intersectionangle[#,Point@First[intersection@@#]]&@{Circle[],Circle[{.5,0},.5]}

intersectionangle[#,Point@First[intersection@@#]]&@{Circle[],Circle[{.5,0},.49]}

With[{θ=0.0001},With[{pt1={0,0},pt2=cartesian[E^(I θ)],pt={.5,.5},r=.5},intersectionangle[#,Point@First[intersection@@#]]&@{Line@{pt1,pt2},Circle[pt,r]}]]

intersectionangle[#,Point@First[intersection@@#]]&/@{{Circle[{0.5`,0},(1/(2 (Sqrt[2])))],Circle[{0,0.5`},0.35355349059327373`]},{Line[{{0,0},{(1/2),((Sqrt[3])/2)}}],Circle[{0.5`,0.5`},0.5`]}}

With[{pt1={0,0}},Manipulate[With[{pt2=u cartesian[E^(I .3)],r=.25},{clip@#,intersectionangle[#,Point@First[intersection@@#]]}&@{Circle[pt1,r],Circle[pt2,r]}],{u,.01,1}]]

Plot[With[{pt1={0,0},pt2={u,0},r=.25},intersectionangle[#,Point@First[intersection@@#]]&@{Circle[pt1,r],Circle[pt2,r]}],{u,0,1}]

Projection orthogonale d'un point sur une droite

Clear@project;
project[Point@pt_List,Line@{pt1_List,pt2_List}]:=pt1+Dot[pt-pt1,#]#&@Normalize[pt2-pt1]

With[{pt={4,1},pt1={1,1},pt2={2,3}},Graphics[{Point@pt1,Point@pt2,Point@pt,Red,Point@project[Point@pt,Line@{pt1,pt2}]},Axes->True,AxesOrigin->{0,0},ImageSize->Small]]

Intersection droite-cercle

La droite est un diamètre (du cercle unité) d'angle polaire θ.  On n'a pas besoin de plus en géométrie hyperbolique.  À faire : généraliser à droite quelconque pour faciliter l'exposé.

Clear@lineintersectionSolve;
lineintersectionSolve[x_,y_,r_,θ_]:=Evaluate@Block[{x1,y1},{x1,y1}/.Simplify@Solve[{euclideandistance[{x1,y1},{x,y}]==r,y1 Cos@θ==x1 Sin@θ},{x1,y1}]]

?lineintersectionSolve

With[{x=0,y=1,r=1/2,θ=Pi/3},lineintersectionSolve[x,y,r,θ]]

Singularité de Cot[θ] pour θ=0 mod Pi.

With[{x=1/2,y=1/2,r=1/2,θ=0},lineintersectionSolve[x,y,r,θ]]

Block[{x1,y1},{x1,y1}/.Simplify@Solve[{euclideandistance[{x1,y1},{x,y}]==r,y1 ==0},{x1,y1}]]

Le cas θ=Pi/2 mod Pi est traité aussi, bien que régulier, par symétrie.  Éliminer solution imaginaire.

ClearAll@lineintersection;

lineintersection[x_,y_,r_,θ_]/;chop@Sin@θ==0&&chop[r-Abs@y]≥0:=Evaluate@Block[{x1,y1},{x1,y1}/.Simplify@Solve[{euclideandistance[{x1,y1},{x,y}]==r,y1 ==0},{x1,y1}]]

lineintersection[x_,y_,r_,θ_]/;chop@Cos@θ==0&&chop[r-Abs@x]≥0:=Evaluate@Block[{x1,y1},{x1,y1}/.Simplify@Solve[{euclideandistance[{x1,y1},{x,y}]==r,x1 ==0},{x1,y1}]]

With[{x=1/2,y=1/2,r=1/2,θ=Pi/2},lineintersection[x,y,r,θ]]

With[{x=1/2,y=1/2,r=1/2,θ=Pi},lineintersection[x,y,r,θ]]

With[{x=1/2,y=1/2,r=1/2,θ=-Pi/2},lineintersection[x,y,r,θ]]

lineintersection[1/2,0,1/2,0]

lineintersection[1/2,0,1/3,0]

lineintersection[1/2,0,1/3,Pi/2]

compilelineintersection=Compile[{x,y,r,θ},Evaluate@lineintersectionSolve[x,y,r,θ]];

With[{x=1/2,y=1/2,r=1/2,θ=Pi/4},compilelineintersection[x,y,r,θ]]

With[{x=1/2,y=1/2,r=1/2,θ=.00001},compilelineintersection[x,y,r,θ]]

Pourquoi erreur ?  Peut-être racine carrée de (petit) nombre négatif.  Inévitable à la marge.

With[{x=0,y=1,r=1/2,θ=Pi/3},compilelineintersection[x,y,r,θ]]

La distance de la droite au centre du cercle doit être inférieure au rayon pour que l'intersection soit non vide.

lineintersection::numerr="Error in compilelineintersection."

lineintersection[x_,y_,r_,θ_]/;Negative@chop[r-euclideandistance[{x,y},project[Point@{x,y},Line@{{0,0},cartesian[E^(I θ)]}]]]:={}

lineintersection[x_,y_,r_,θ_]:=Check[#,Message@lineintersection::numerr;Quiet@#]&@Unevaluated@compilelineintersection[x,y,r,θ]

With[{x=0,y=1,r=1/2,θ=Pi/3},lineintersection[x,y,r,θ]]

With[{x=0,y=1,r=1/2},Manipulate[Grid@List@{Graphics[{Circle[{x,y},r],Red,Line@{{0,0},(y+r)cartesian[E^(I θ)]},Green,PointSize->.03,Point@Quiet@lineintersection[x,y,r,θ]},Axes->True,PlotRange->{{-.5,.5},{0,1.5}}],r-euclideandistance[#,project[Point@#,Line@{{0,0},cartesian[E^(I θ)]}]]&@{x,y}},{{θ,Pi/3},0,Pi/2}]]

With[{x=.2,y=.8,r=.5,θ=.6},lineintersection[x,y,r,θ]]

lineintersection[x,1/2,1/2,0]

lineintersection[.2,.8,.5,.4]

lineintersection[1/2,1/2,1/2,0]

lineintersection[1/2,1/2,1/2,1/3]

lineintersection[.5,.5,.5,Pi/4]

lineintersection[1/2,1/2,1/2,0.]

lineintersection[1/2,0,1/2,0.00001]

lineintersection[1/2,0,1/2,.1]

If[False,Identity,Reverse][{x,y}]

ClearAll@intersection;

Attributes@intersection={Orderless};

Options@intersection={Compiled->True};

intersection[Line@{pt1_List,pt2_List},Circle[pt_List,r_:1],option___Rule]/;chop@Det@{pt1,pt2}==0:=Sort[#,closerQ]&@Union[#,SameTest->sametest]&@If[Compiled/.{option}/.Options@intersection,lineintersection,lineintersectionSolve][Sequence@@pt,r,Arg@complex[pt2-pt1]]

With[{pt={0,1},r=1/2,θ=Pi/3},intersection[Line@{{0,0},cartesian[E^(I θ)]},Circle[pt,r]]]

With[{pt={0,1},r=1/2,θ=Pi/3},intersection[Line@{{0,0},cartesian[E^(I θ)]},Circle[pt,r],Compiled->False]]

intersection[Line@{{0,0},cartesian@I},Circle[{1/2,0},1/3]]

intersection[Line@{{0,0},cartesian@I},Circle[{.5,0}]]

intersection[Line@{{0,0},cartesian@I},Circle[{.5,0},.1]]

intersection[Line@{{0,0},cartesian[E^(I 1.5)]},Circle[{.2,.8},.5]]

intersection[Line@{cartesian[E^(I 1.5)],{0,0}},Circle[{.2,.8},.5]]

intersection[Line@{#,-#}&@cartesian[E^(I 1.5)],Circle[{.2,.8},.5]]

Graphics[{Red,##,Blue,Point@intersection@##}&[Circle[{.2,.8},.5],Line@{{0,0},cartesian@I}],ImageSize->Small]

Graphics[{Red,##,Blue,Point@intersection@##}&[Circle[{1/2,0},1/3],Line@{{0,0},{1,0}}],ImageSize->Small]

Graphics[{Red,##,Blue,Point@intersection@##}&[Circle[{1/2,0},1/3],Line@{{0,0},cartesian@I}],ImageSize->Small]

Graphics[{Red,##,Blue,Point@intersection@##}&[Circle[{0,0},.5],Line@{{0,0},cartesian@I}],ImageSize->Small]

Manipulate[With[{c=E^(I θ)},Graphics[{Circle[{1/2,1/2},1/2],PointSize->.04,Red,Point@intersection[Line@{{0,0},cartesian@c},Circle[{1/2,1/2},1/2]]},Axes->True,ImageSize->Small]],{θ,0,Pi/2}]

Intersection cercle-cercle

Calcul assez long, ne pas évaluer dans l'initialisation.

Block[{x,y},{x,y}/.FullSimplify@Solve[{euclideandistance[{x,y},{x1,y1}]==r1,euclideandistance[{x,y},{x2,y2}]==r2},{x,y}]]

Cas diagonal singulier.

Block[{x,y},{x,y}/.FullSimplify@Solve[{euclideandistance[{x,y},{x1,y1}]==r1,euclideandistance[{x,y},{x1,y2}]==r2},{x,y}]]

Cas diagonal symétrique mais non singulier :

Block[{x,y},{x,y}/.FullSimplify@Solve[{euclideandistance[{x,y},{x1,y1}]==r1,euclideandistance[{x,y},{x2,y1}]==r2},{x,y}]]

Clear@circleintersectionSolve;
circleintersectionSolve[x1_,y1_,r1_,x2_,y2_,r2_]:={{(-(r1^2) (((x1-x2))^2)+(x1-x2) ((r2^2) (x1-x2)+(x1+x2) ((((x1-x2))^2)+(((y1-y2))^2)))+y1 √(-(((x1-x2))^2) ((r1^4)+(((-(r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))^2)-2 (r1^2) ((r2^2)+(((x1-x2))^2)+(((y1-y2))^2))))-√(-(((x1-x2))^2) ((r1^4)+(((-(r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))^2)-2 (r1^2) ((r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))) y2)/(2 (x1-x2) ((((x1-x2))^2)+(((y1-y2))^2))),(1/(2 ((((x1-x2))^2)+(((y1-y2))^2))))(-√(-(((x1-x2))^2) ((((r1-r2))^2)-(((x1-x2))^2)-(((y1-y2))^2)) ((((r1+r2))^2)-(((x1-x2))^2)-(((y1-y2))^2)))+(r2^2) (y1-y2)+(r1^2) (-y1+y2)+((((x1-x2))^2)+(((y1-y2))^2)) (y1+y2))},{(-(r1^2) (((x1-x2))^2)+(x1-x2) ((r2^2) (x1-x2)+(x1+x2) ((((x1-x2))^2)+(((y1-y2))^2)))-y1 √(-(((x1-x2))^2) ((r1^4)+(((-(r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))^2)-2 (r1^2) ((r2^2)+(((x1-x2))^2)+(((y1-y2))^2))))+√(-(((x1-x2))^2) ((r1^4)+(((-(r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))^2)-2 (r1^2) ((r2^2)+(((x1-x2))^2)+(((y1-y2))^2)))) y2)/(2 (x1-x2) ((((x1-x2))^2)+(((y1-y2))^2))),(1/(2 ((((x1-x2))^2)+(((y1-y2))^2))))(√(-(((x1-x2))^2) ((((r1-r2))^2)-(((x1-x2))^2)-(((y1-y2))^2)) ((((r1+r2))^2)-(((x1-x2))^2)-(((y1-y2))^2)))+(r2^2) (y1-y2)+(r1^2) (-y1+y2)+((((x1-x2))^2)+(((y1-y2))^2)) (y1+y2))}}

Clear@circleintersectionSolve1;
circleintersectionSolve1[x1_,y1_,r1_,y2_,r2_]:={{x1-(1/(2 (((y1-y2))^2)))(√(-(((y1-y2))^2) (r1-r2+y1-y2) (r1+r2+y1-y2) (r1-r2-y1+y2) (r1+r2-y1+y2))),((-(r1^2)+(r2^2)+(y1^2)-(y2^2))/(2 (y1-y2)))},{x1+(1/(2 (((y1-y2))^2)))(√(-(((y1-y2))^2) (r1-r2+y1-y2) (r1+r2+y1-y2) (r1-r2-y1+y2) (r1+r2-y1+y2))),((-(r1^2)+(r2^2)+(y1^2)-(y2^2))/(2 (y1-y2)))}}

Clear@circleintersectionSolve2;
circleintersectionSolve2[x1_,y1_,r1_,x2_,r2_]:={{((-(r1^2)+(r2^2)+(x1^2)-(x2^2))/(2 (x1-x2))),-(1/(2 (((x1-x2))^2)))(√(-(((x1-x2))^2) (r1-r2+x1-x2) (r1+r2+x1-x2) (r1-r2-x1+x2) (r1+r2-x1+x2)))+y1},{((-(r1^2)+(r2^2)+(x1^2)-(x2^2))/(2 (x1-x2))),(1/(2 (((x1-x2))^2)))(√(-(((x1-x2))^2) (r1-r2+x1-x2) (r1+r2+x1-x2) (r1-r2-x1+x2) (r1+r2-x1+x2)))+y1}}

With[{x1=1/2,y1=0,r1=Sqrt@2/4,x2=0,y2=1/2},With[{r2=r1},{Graphics@{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},circleintersectionSolve[x1,y1,r1,x2,y2,r2]}]]

circleintersectionSolve[x1,y1,r1,x1,y2,r2]

circleintersectionSolve[x1,y1,r1,x2,y1,r2]

circleintersectionSolve1[x1,y1,r1,y2,r2]

circleintersectionSolve2[x1,y1,r1,x2,r2]

Échanger x,y :

Reverse/@circleintersectionSolve2[y1,x1,r1,y2,r2]==circleintersectionSolve1[x1,y1,r1,y2,r2]

compilecircleintersection1=Compile[{x1,y1,r1,y2,r2},Evaluate@circleintersectionSolve1[x1,y1,r1,y2,r2]];

compilecircleintersection2=Compile[{x1,y1,r1,x2,r2},Evaluate@circleintersectionSolve2[x1,y1,r1,x2,r2]];

With[{x1=1/2,y1=1/2,r1=1,x2=1/2,y2=-1/2,r2=1},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];compilecircleintersection1[x1,y1,r1,y2,r2])]

With[{x1=1/2,y1=1/2,r1=1/2,x2=-1/2,y2=1/2,r2=1/2},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];compilecircleintersection2[x1,y1,r1,x2,r2])]

compilecircleintersection=Compile[{x1,y1,r1,x2,y2,r2},Evaluate@circleintersectionSolve[x1,y1,r1,x2,y2,r2]];

With[{x1=0.,y1=1.817,r1=1.517,x2=-1.727752671269529`,y2=0.5613808731144879`,r2=1.517},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];compilecircleintersection[x1,y1,r1,x2,y2,r2])]

Timing@Do[compilecircleintersection[0.,1.817,1.517,-1.727752671269529`,0.5613808731144879`,1.517],{100}]

Petit paradoxe : calcul symbolique plus rapide (après compilation) que calcul numérique.

Block[{circleintersectionNSolve=Function[{x1,y1,r1,x2,y2,r2},Block[{x,y},{x,y}/.NSolve[(x-#[[1,1]])^2+(y-#[[1,2]])^2 ==Last@#^2&/@{{{x1,y1},r1},{{x2,y2},r2}},{x,y}]]]},
{circleintersectionNSolve[0.,1.817,1.517,-1.727752671269529`,0.5613808731144879`,1.517],Timing@Do[circleintersectionNSolve[0.,1.817,1.517,-1.727752671269529`,0.5613808731144879`,1.517],{100}]}
]

With[{x1=1/2,y1=0,r1=1/2,x2=0,y2=1/2,r2=1/2},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];compilecircleintersection[x1,y1,r1,x2,y2,r2])]

Problème de précision marginale.

With[{x1=1/2,y1=0,r1=Sqrt@2/4,x2=0,y2=1/2},With[{r2=r1},{Graphics@{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},compilecircleintersection[x1,y1,r1,x2,y2,r2]}]]

With[{x1=1/2,y1=0,r1=Sqrt@2/4,x2=0,y2=1/2},With[{r2=r1+.0000000000001},{Graphics@{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},compilecircleintersection[x1,y1,r1,x2,y2,r2]}]]

With[{x1=1/2,y1=0,r1=Sqrt@2/4,x2=0,y2=1/2},With[{r2=r1+.00000000000000001},{Graphics@{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},compilecircleintersection[x1,y1,r1,x2,y2,r2]}]]

ClearAll@circleintersection;

circleintersection[x1_,y1_,r1_,x2_,y2_,r2_]/;Positive@chop[euclideandistance[{x1,y1},{x2,y2}]-(r1+r2)]||Negative@chop[euclideandistance[{x1,y1},{x2,y2}]-Abs[r1-r2]]:={}

circleintersection::numerr1="Error in compilecircleintersection1."

circleintersection[x1_,y1_,r1_,x2_,y2_,r2_]/;chop[x2-x1]==0:=Check[#,Message@circleintersection::numerr1;Quiet@#]&@Unevaluated@compilecircleintersection1[x1,y1,r1,y2,r2]

circleintersection::numerr2:="Error in compilecircleintersection2."

circleintersection[x1_,y1_,r1_,x2_,y2_,r2_]/;chop[y2-y1]==0:=Check[#,Message@circleintersection::numerr1;Quiet@#]&@Unevaluated@compilecircleintersection2[x1,y1,r1,x2,r2]

circleintersection::numerr="Error in compilecircleintersection."

circleintersection[x1_,y1_,r1_,x2_,y2_,r2_]:=Check[#,Message@circleintersection::numerr;Quiet@#]&@Unevaluated@compilecircleintersection[x1,y1,r1,x2,y2,r2]

With[{x1=1/2,y1=1/2,r1=1,x2=1/2,y2=-1/2,r2=1},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];circleintersection[x1,y1,r1,x2,y2,r2])]

With[{x1=1/2,y1=1/2,r1=1/2,x2=-1/2,y2=1/2,r2=1/2},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small,Axes->True];circleintersection[x1,y1,r1,x2,y2,r2])]

circleintersection[0,0,1,.5,0,.49]

circleintersection[0,0,1,.5,0,.5]

circleintersection[0,0,1,.5,0,.4999999999999999]

circleintersection[0,0,1,.5,0,.49999999999999999]

With[{x1=-0.53272,y1=0.86304,r1=0.16923,x2=-0.49507,y2=1.02802,r2=0.54948},(Print@Graphics[{Circle[{x1,y1},r1],Circle[{x2,y2},r2]},ImageSize->Small];circleintersection[x1,y1,r1,x2,y2,r2])]

circleintersection[1/2,0,Sqrt@2/4,0,1/2,Sqrt@2/4]

À faire : cas diagonaux aussi pour Compiled -> False.

intersection[Circle[{x1_,y1_},r1_:1],Circle[{x2_,y2_},r2_:1],option___Rule]:=
Sort[#,closerQ]&@
Union[#,SameTest->sametest]&@If[(Compiled/.{option}/.Options@intersection),
circleintersection[x1,y1,r1,x2,y2,r2],
Which[
chop[x2-x1]==0,circleintersectionSolve1[x1,y1,r1,y2,r2],
chop[y2-y1]==0,circleintersectionSolve2[x1,y1,r1,x2,r2],
True,circleintersectionSolve[x1,y1,r1,x2,y2,r2]
]
]

intersection[Circle[{0,1},1/2],Circle[{0,0},1/2],Compiled->False]

intersection[Circle[{1,0},1/2],Circle[{0,0},1/2],Compiled->False]

intersection[Circle[{0,1.817},1.517],Circle[{-1.727752671269529`,0.5613808731144879`},1.517],Compiled->False]

intersection[Circle[{0,1},1/2],Circle[{0,0},1/2],Compiled->True]

intersection[Circle[{0,1},1/2],Circle[{0,0},1/2]]

intersection[Circle[{1,0},1/2],Circle[{0,0},1/2]]

intersection[Circle[{0,1},1/2],Circle[{1,0},1/2]]

intersection[Circle[{0,1.817},1.517],Circle[{-1.727752671269529`,0.5613808731144879`},1.517]]

Timing@Do[intersection[Circle[{0,1.817},1.517],Circle[{-1.727752671269529`,0.5613808731144879`},1.517],Compiled->True],{1000}]
Timing@Do[intersection[Circle[{0,1.817},1.517],Circle[{-1.727752671269529`,0.5613808731144879`},1.517],Compiled->False],{1000}]

intersection[Circle[{x1,y1},r1],Circle[{x2,y2},r2],Compiled->False]

intersection[Circle[{-0.35869745325651586`,1.1644957554275264`},0.6670832032063166`],Circle[]]

intersection[Circle[],Circle[{1/2,0}]]

Graphics[{#,Red,PointSize->.03,Point[intersection@@#]}&@{Circle[{0,1.817},1.517],Circle[{-1.727752671269529`,0.5613808731144879`},1.517]},Axes->True,ImageSize->Small]

Graphics[{#,Red,PointSize->.04,Point[intersection@@#]}&@{Circle[{0,1.817}],Circle[{0,0.5613808731144879`},.4]},ImageSize->Small]

Arc de cercle limité par le cercle unité

Arcs complémentaires.

Graphics[Circle[{0,0},1,{.2,.4}],Axes->True,ImageSize->Small,PlotRange->square[]]
Graphics[Circle[{0,0},1,{.4-2Pi,.2}],Axes->True,ImageSize->Small]

(Print@Graphics[#,ImageSize->Small];#)&@{##,Point@intersection[##]}&[Circle[],Circle[{.5,0},.8]]

L'intersection doit contenir deux points distincts.  À cause de la coupure de Arg dans le plan complexe, l'arc est tantôt extérieur ou intérieur.

Manipulate[Graphics[{Circle[],Point@First@#,Circle[Sequence@@#1,Sort[#2,LessEqual]]},ImageSize->Small,PlotRange->square@1.8]&[#,Flatten[#,1]&@Outer[Arg@complex[#2-#1]&,{First@#},intersection[Circle[],#],1,1]]&@Circle[.9{Cos@θ1,Sin@θ1},.8],{θ1,0,2Pi}]

Manipulate[Graphics[{Circle[],Point@First@#,Circle[Sequence@@#1,Sort[#2,LessEqual]]},ImageSize->Small,PlotRange->square@1.8]&[#,Flatten[#,1]&@Outer[argcut[complex[#2-#1],Arg@complex@#1]&,{First@#},intersection[Circle[],#],1,1]]&@Circle[.9{Cos@θ1,Sin@θ1},.8],{θ1,0,2Pi}]

With[{θ1=0},Flatten[#,1]&@Outer[argcut[complex[#2-#1],Arg@complex@#1]&,{First@#},intersection[Circle[],#],1,1]&@Circle[.9{Cos@θ1,Sin@θ1},.8]]

Coupure passe par le centre du cercle mobile.

arc@Circle[pt_,r_:1]:=Circle[pt,r,Sort[Flatten[#,1]&@Outer[argcut[complex[#2-#1],Arg@complex@#1]&,{pt},intersection[Circle[],Circle[pt,r]],1,1],LessEqual]]

Manipulate[Graphics[{Circle[],Point@First@#,arc@#}&@Circle[.9{Cos@θ1,Sin@θ1}],ImageSize->Small,PlotRange->square@1.8],{θ1,0,2Pi}]

Fenêtre circulaire

Fond noir.  Trop de noir pour l'imprimante.

Graphics[{Black,Rectangle[{-1,-1},{1,1}],White,Disk[],Black,Circle[{.5,0}]},PlotRange->square[],ImageSize->Tiny]

Fond blanc.

Indiqué par Guillaume Santini.

Show[{Graphics[{Circle@{.5,0}}],RegionPlot[x^2+y^2>1,{x,-1.5,1.5},{y,-1.5,1.5},PlotStyle->White,BoundaryStyle->Black]},PlotRange->square@1.05,ImageSize->Tiny]

Arc de cercle interne.  À faire : λ-calcul pour éliminer graphics.

ClearAll@clip;

clip::option="Unknown Method option ignored."

Options@clip={Method->Background};

clip[directives_,option___Rule]:=Switch[Method/.{option}/.Options@clip,

None,
Graphics[Prepend[directives,Circle[]],Sequence@@#],

Background,
Graphics[{Black,Rectangle[{-1.05,-1.05},{1.05,1.05}],White,Disk[],Black,directives},Sequence@@#,PlotRange->square[]],

RegionPlot,
Show[{Graphics@directives,RegionPlot[x^2+y^2>1,{x,-1.1,1.1},{y,-1.1,1.1},Sequence@#,PlotStyle->White,BoundaryStyle->Black]&@FilterRules[{option},Options@RegionPlot]},Sequence@@#,PlotRange->square@1.05],

Circle,
Graphics[{Circle[],directives/.Circle[pt_,r___]:>arc@Circle[pt,r]},Sequence@@#,PlotRange->square@1.05],

_,
Message@clip::option;Graphics[directives,Sequence@@#]

]&@FilterRules[{option},Options@Graphics]

clip[{Circle@{.5,0}},ImageSize->Tiny,Method->xxx]

clip[{Circle@{.5,0}},ImageSize->Tiny,Method->None]

clip[{Blue,Circle@{.5,0},Line@{{-1,-1},{1,1}}},Method->Circle,ImageSize->Tiny]

With[{n=5},Animate[clip[{Line[{{0,0},{Cos[Re[θ]],Sin[Re[θ]]}}],Line[{{0,0},{Cos[(π/5)+Re[θ]],Sin[(π/5)+Re[θ]]}}],Line[{{0,0},{Sin[(π/10)-Re[θ]],Cos[(π/10)-Re[θ]]}}],Line[{{0,0},{-Sin[(π/10)+Re[θ]],Cos[(π/10)+Re[θ]]}}],Line[{{0,0},{-Cos[(π/5)-Re[θ]],Sin[(π/5)-Re[θ]]}}],Line[{{0,0},{-Cos[Re[θ]],-Sin[Re[θ]]}}],Line[{{0,0},{-Cos[(π/5)+Re[θ]],-Sin[(π/5)+Re[θ]]}}],Line[{{0,0},{-Sin[(π/10)-Re[θ]],-Cos[(π/10)-Re[θ]]}}],Line[{{0,0},{Sin[(π/10)+Re[θ]],-Cos[(π/10)+Re[θ]]}}],Line[{{0,0},{Cos[(π/5)-Re[θ]],-Sin[(π/5)-Re[θ]]}}]},ImageSize->Tiny,Method->Background],{θ,0,Pi}]]

Le pdf exporté contient des saletés hors du cercle unité !

clip[{Blue,Circle@{.5,0},Line@{{-1,-1},{1,1}}},Method->RegionPlot,ImageSize->Tiny]

Export["RegionPlot.pdf",%]

Contour anguleux

With[{n=5},Animate[clip[{Line[{{0,0},{Cos[Re[θ]],Sin[Re[θ]]}}],Line[{{0,0},{Cos[(π/5)+Re[θ]],Sin[(π/5)+Re[θ]]}}],Line[{{0,0},{Sin[(π/10)-Re[θ]],Cos[(π/10)-Re[θ]]}}],Line[{{0,0},{-Sin[(π/10)+Re[θ]],Cos[(π/10)+Re[θ]]}}],Line[{{0,0},{-Cos[(π/5)-Re[θ]],Sin[(π/5)-Re[θ]]}}],Line[{{0,0},{-Cos[Re[θ]],-Sin[Re[θ]]}}],Line[{{0,0},{-Cos[(π/5)+Re[θ]],-Sin[(π/5)+Re[θ]]}}],Line[{{0,0},{-Sin[(π/10)-Re[θ]],-Cos[(π/10)-Re[θ]]}}],Line[{{0,0},{Sin[(π/10)+Re[θ]],-Cos[(π/10)+Re[θ]]}}],Line[{{0,0},{Cos[(π/5)-Re[θ]],-Sin[(π/5)-Re[θ]]}}]},ImageSize->Tiny,Method->RegionPlot],{θ,0,Pi}]]

clip[{Blue,Circle@{.5,0}},ImageSize->Small,Method->Circle,ImageSize->Tiny]

Non prévu mais tant pis.

clip[{Blue,Circle@{.5,0},Line@{{-1,-1},{1,1}}},Method->Circle,ImageSize->Tiny]

Fenêtre rectangulaire tournante

Convient pour une rotation d'angle multiple de Pi/2 mais non pour une rotation d'angle Pi/4.

Graphics[{Circle[],wheel[5,0]},Axes->True,GridLines->Automatic,ImageSize->Small,PlotRange->Transpose@Map[pointrotate[#,Pi/2]&,Transpose@{{.5,1},{0,.3}}]]
Graphics[{Circle[],wheel[5,0]},Axes->True,GridLines->Automatic,ImageSize->Small,PlotRange->Transpose@Map[pointrotate[#,Pi/4]&,Transpose@{{.5,1},{0,.3}}]]

Faire tourner les quatre coins et utiliser le rectangle enveloppant dont les côtés sont parallèles aux axes.

Through[{Min,Max}@#]&/@Transpose[pointrotate[#,.3]&/@Distribute[{{.5,1},{0,.3}},List]]

Inutile si la fenêtre est invariante par rotation d'angle Pi/2 autour de l'origine.

Clear@enveloprotate;
enveloprotate[plotrange:{Repeated[_List,{2}]},θ_]:=Map[Through[{Min,Max}@#]&,Transpose[pointrotate[#,θ]&/@Distribute[#,List]]]&@plotrange

Manipulate[Graphics[{Circle[],wheel[5,0]},Axes->True,GridLines->Automatic,PlotRange->enveloprotate[{{.5,1},{0,.3}},θ]],{θ,0,2Pi}]

Droites hyperboliques

Droite hyperbolique orthogonale à un diamètre

Ne marche pas avec pdf.

Import@"paramètre d'échelle.gif"

Solve[{u==z-r,z^2==r^2+1},{z,r}]

Sur le dessin.

(*r*)6.05/4.05

(*z*)7.3/4.05

(*u*)1.2/4.05

With[{z=1.8},With[{u=z-Sqrt[z^2-1]},{u,With[{r=((1-u^2)/(2u))},r]}]]

With[{c=(1+I)/2},Graphics[{Circle[],Red,Point@cartesian@c,Circle[cartesian[((1+Abs@c^2)/(2Abs@c))Normalize@c],((1-Abs@c^2)/(2Abs@c))]},ImageSize->Small]]

With[{c=1+I},Graphics[{Circle[],Red,Point@cartesian@c,Circle[cartesian[((1+Abs@c^2)/(2Abs@c))Normalize@c],((1-Abs@c^2)/(2Abs@c))]},ImageSize->Small]]

(1+{-1,1}#^2)/(2#)&@Abs@c

{Normalize@#,Apply[Sequence,(1+{1,-1}#^2)/(2#)&@Abs@#]}&@c

Circle[cartesian[#1#2],#3]&[Normalize@#,Apply[Sequence,(1+{1,-1}#^2)/(2#)&@Abs@#]]&@c==Circle[cartesian[((1+Abs@c^2)/(2Abs@c))Normalize@c],((1-Abs@c^2)/(2Abs@c))]

Clear@HL;

HL@Point@pt_List:=Composition[Circle[cartesian[#1#2],#3]&][Normalize@complex@pt,Apply[Sequence,(1+{1,-1}#^2)/(2#)&@euclideannorm@pt]]

HL@Point@{x,y}

À faire : démontrer que l'intersection de deux droites hyperboliques distinces ne contient qu'un point dans le disque hyperbolique.  (C'est le 1er postulat d'Euclide.)

Manipulate[clip[{HL@Point@cartesian[u E^(I θ)],HL@Point@{u1,0}},Axes->True,ImageSize->Small],{{u1,.5},.01,1},{{u,.5},.01,1},{θ,0,Pi}]

Droites hyperboliques en miroir sur un diamètre

À faire : démontrer que le second point d'intersection est indépendant de θ (conjugaison optique).

With[{pt1={0.,0.54}},Manipulate[With[{pt2=cartesian[Normalize@complex@pt1 E^(I θ)]},With[{p3=only@Block[{x,y},{x,y}/.Solve[{pt2.({x,y}-pt2)==0,(pt2-pt1).({x,y}-((pt1+pt2)/2))==0},{x,y}]]},With[{p4=pointmirror[p3,Arg@complex@pt1]},Graphics[{Circle[],PointSize->.02,Point/@{pt1,pt2,p3,p4},Text["pt1",pt1+{.2,0}],Text["pt2",pt2-{0,.1}],Text["p3",p3-{0,.1}],Circle[p3,euclideandistance[p3,pt1]],Circle[p4,euclideandistance[p3,pt1]]},Axes->True,ImageSize->Medium,PlotRange->{{-2,2},{-1,2.5}}]]]],{{θ,1},0,Pi}]]

Clear@mirrorHLs;mirrorHLs[Point@pt1_List,θ_?NumericQ]:=With[{pt2=cartesian[Normalize@complex@pt1 E^(I θ)]},With[{p3=only@Block[{x,y},{x,y}/.Solve[{pt2.({x,y}-pt2)==0,(pt2-pt1).({x,y}-((pt1+pt2)/2))==0},{x,y}]]},mirrororbit[Arg@complex@pt1]@Circle[p3,euclideandistance[p3,pt1]]]]

FullSimplify@mirrorHLs[Point@{1,1},θ]

mirrorHLs[Point@{0,.6},.8]

Manipulate[Graphics[{Circle[],Riffle[mirrorHLs[Point@cartesian[u E^(-I θ1)],θ],{Red}]},PlotRange->square@2,Axes->True],{{u,.6},.3,.8},{θ,.3,Pi/2},{θ1,0,2Pi}]

Droite hyperbolique passant par deux points

With[{pt1={.2,.8},pt2={-.3,.5}},With[{m=((pt2-pt1)/2)},Manipulate[Graphics[{Circle[],{Point@pt1,Text["pt1",pt1+.05{1,1}],Point@pt2,Text["pt2",pt2+.05{1,1}],With[{p3=pt1+m-z Normalize@pointrotate[m,Pi/2]},{Point@p3,Text["p3",p3+.05{1,1}],{#,With[{p4=First@intersection[#,Circle[]]},{Point@p4,Text["p4",p4+.05{1,1}]}]}&@Circle[p3,Sqrt[#.#&@m+z^2]]}]}},PlotRange->{{-1.5,1},{0,2}},Axes->True],{{z,.6},0,1}]]]

With[{pt1={.2,.8},pt2={-.3,.5},z=.6},With[{m=((pt2-pt1)/2)},With[{p3=pt1+m-z Normalize@pointrotate[m,Pi/2]},With[{p4=First@intersection[Circle[p3,Sqrt[#.#&@m+z^2]],Circle[]]},p4.(p4-p3)]]]]

With[{pt1={.2,.8},pt2={-.3,.5}},With[{m=((pt2-pt1)/2)},FindRoot[With[{p3=pt1+m-#  Normalize@pointrotate[m,Pi/2]&@z},With[{p4=First@intersection[Circle[p3,Sqrt[#.#&@m+z^2]],Circle[]]},p4.(p4-p3)]],{z,.5},Evaluated->False]]]

Mettre en commun (sans les nommer) les fonctions opérandes.

With[{pt1={.2,.8},pt2={-.3,.5}},With[{m=((pt2-pt1)/2)},FindRoot[With[{p3=#1@z},With[{p4=First@intersection[#2[p3,z],Circle[]]},p4.(p4-p3)]],{z,.5},Evaluated->False]&[pt1+m-#  Normalize@pointrotate[m,Pi/2]&,Function[{p3,z},Circle[p3,Sqrt[#.#&@m+z^2]]]]]]

With[{pt1={.2,.8},pt2={-.3,.5}},With[{m=((pt2-pt1)/2)},Block[{z},#2[#1@z,z]/.FindRoot[With[{p3=#1@z},With[{p4=First@intersection[#2[p3,z],Circle[]]},p4.(p4-p3)]],{z,.5},Evaluated->False]]&[pt1+m-#  Normalize@pointrotate[m,Pi/2]&,Function[{p3,z},Circle[p3,Sqrt[#.#&@m+z^2]]]]]]

Il faut que les points soient ordonnés circulairement, sinon le centre du cercle est du mauvais côté (sur la médiatrice).

HL[Point@pt1_List,Point@pt2_List]:=Apply[Function[{q1,q2},With[{m=((q2-q1)/2)},Block[{z},#2[#1@z,z]/.FindRoot[With[{p3=#1@z},With[{p4=First@intersection[#2[p3,z],Circle[]]},p4.(p4-p3)]],{z,.5},Evaluate[Sequence@@precisions],Evaluated->False]]&[q1+m-#  Normalize@pointrotate[m,Pi/2]&,Function[{p3,z},Circle[p3,Sqrt[#.#&@m+z^2]]]]]],sortdet@{pt1,pt2}]

With[{pt1={.2,.8},pt2={-.3,.5}},Graphics[{Circle[],#,HL@@#},ImageSize->Small]&@{Point@pt1,Point@pt2}]

With[{pt1={.2,.7},pt2={-.2,.7}},Graphics[{Circle[],#,HL@@#},ImageSize->Small]&@{Point@pt1,Point@pt2}]

HL[Point[{-0.026067265650372838`,0.9506257070730416`}],Point[{0.026067265650372838`,0.9506257070730416`}]]

HL@@{Point[{-0.026067265650371818`,0.9506257070730462`}],Point[{0.026067265650371818`,0.9506257070730463`}]}

HL[Point[{-0.02,0.95}],Point[{0.02,0.95}]]

À faire : droite hyperbolique diamètre.

With[{pt1={.2,.7},pt2={-.1,-.7/2}},Graphics[{Circle[],Line@#,Point@#,Point@{0,0},HL@@Point/@#},ImageSize->Small]&@{pt1,pt2}]

Droite hyperbolique passant par un point et faisant un angle donné avec le diamètre passant par ce point

Trouver u tel que les deux cercles se coupent orthogonalement.  Solve ou NSolve ne sont pas adaptés.  À faire : chercher une solution plus proche du cas θ=Pi/2.

With[{c=1/2 I,θ=Pi/2},Solve[FullSimplify[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#,Compiled->False]}&@#@u==0],{u}]&[Circle[cartesian[c+# Normalize@c E^(I (θ-Pi/2))],#]&]]

With[{c=.2+.4I},Manipulate[{Graphics[#,Axes->True,PlotRange->square@1.5],(#1-#2).#2&[First@#1,only@#2]&@@Take[#,-2]}&@{Circle[],HL[Point@cartesian@c,0],Sequence@@{Point@#,Sequence@@{#,Point@First@intersection[Circle[],#]}&@Circle[#,u]}&@cartesian[c+u Normalize@c E^(I (θ-Pi/2))]},{{u,.92},.3,15},{{θ,Pi/2+.25},0,Pi}]]

With[{c=.2+.4I,θ=Pi/2+.25},FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@Circle[cartesian[c+u Normalize@c E^(I( θ-Pi/2))],u],{u,1},Evaluated->False]]

Manipulate[With[{c=.2+.4I},Block[{u},u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@Circle[cartesian[c+u Normalize@c E^(I (θ-Pi/2))],u],{u,1},Evaluated->False]]],{θ,#,Pi-#}]&@.01

Plot[With[{c=.2+.4I},Block[{u},u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@Circle[cartesian[c+u Normalize@c E^(I (θ-Pi/2))],u],{u,1},Evaluated->False]]],{θ,#,Pi-#}]&@.1

Estimation initiale avec les bonnes limites et assurant que le premier cercle essayé coupe le cercle unité !  Il suffit u=1 initialement.

With[{θ=Pi/2},1/((Pi-θ)θ)]

Plot[1/((Pi-θ)θ)/(4/Pi^2),{θ,#,Pi-#}]&@.1

With[{pt={.15,.0},θ=1.45},Block[{u},{u,#@u}/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1/((Pi-θ)θ)/(4/Pi^2)},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt E^(I (Mod[θ,Pi]-Pi/2))],#]&]]

Erreur numérique.  Cercle de grand rayon ne passe pas par l'origine ni par le centre de la roue.

With[{n=5,pt=cartesian[.2E^(-I Pi/5)],θ=.3 10^(-PrecisionGoal+3)/.precisions},Graphics[{Circle[],Point@{0,0},Point@pt,Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1/((Pi-#)#)/(4/Pi^2)&@Mod[θ,Pi]},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt E^(I (Mod[θ,Pi]-Pi/2))],#]&]},ImageSize->Small,PlotRange->square@1.5]]

Indépendant des paramètres de précision.

With[{n=5,pt=cartesian[.2E^(-I Pi/5)],θ=.3 10^-3},Graphics[{Circle[],Point@{0,0},Point@pt,Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1/((Pi-#)#)/(4/Pi^2)&@Mod[θ,Pi]},PrecisionGoal->20,WorkingPrecision->50,AccuracyGoal->20,Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt E^(I (Mod[θ,Pi]-Pi/2))],#]&]},ImageSize->Small,PlotRange->square@1.5]]

Indépendant de l'estimation initiale.

With[{n=5,pt=cartesian[.2E^(-I Pi/5)],θ=.3 10^(-PrecisionGoal+3)/.precisions},Graphics[{Circle[],Point@{0,0},Point@pt,Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt(-I) E^(I θ)],#]&]},ImageSize->Small,PlotRange->square@1.5]]

With[{n=5,pt=cartesian[.2E^(I Pi/5)],θ=.3 10^(-PrecisionGoal+3)/.precisions},Graphics[{Circle[],Point@{0,0},Point@pt,Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt(-I) E^(I θ)],#]&]},ImageSize->Small,PlotRange->square@1.5]]

With[{n=5,pt=cartesian[.2E^(I 2Pi/5)],θ=.5 10^(-PrecisionGoal+3)/.precisions},Graphics[{Circle[],Point@{0,0},Point@pt,Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt(-I) E^(I θ)],#]&]},ImageSize->Small,PlotRange->square@1.5]]

With[{n=5,pt=cartesian[.2E^( I Pi/5)],θ=.5 10^(-PrecisionGoal+3)/.precisions},{Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5],#}&@Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt(-I) E^(I θ)],#]&]]

With[{n=5,pt={.2,0},θ=.5 10^(-PrecisionGoal+3)/.precisions},{Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5],#}&@Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt(-I) E^(I θ)],#]&]]

HL[Point[{0.5498263046756594`,0.013821529825201772`}],-3.469446951953614`*^-18]

HL[Point@pt_,θ_]/;chop@Sin@θ==0:=Line@{-#,#}&@Normalize@pt

HL::singular="Large circle replaced by diameter for HL."

HL[Point@pt_,θ_]/;Abs@Sin@θ<1.8 10^-2:=(Message@HL::singular;Line[{-#,#}&@Normalize@pt])

HL[Point@pt_List,θ_?NumericQ]:=Block[{u},#@u/.FindRoot[(#1-#2).#2&@@{First@#,First@intersection[Circle[],#]}&@#@u,{u,1/((Pi-#)#)/(4/Pi^2)&@Mod[θ,Pi]},Evaluate[Sequence@@precisions],Evaluated->False]]&[Circle[pt+cartesian[# Normalize@complex@pt E^(I (Mod[θ,Pi]-Pi/2))],#]&]

"Large circle replaced by diameter for HL."

With[{c=.15+.05I,θ=1.},Graphics[{Circle[],HL[Point@cartesian@c,0.]},PlotRange->square@1.5,ImageSize->Small]]

With[{n=5,θ=.0251327,u=.55},With[{pt=cartesian[E^(I θ) u]},HL[Point@pt,-Arg@complex@pt+θ]]]

With[{c=.15+.05I,θ=1.},Graphics[{Circle[],HL[Point@cartesian@c,0.01]},PlotRange->square@1.5,ImageSize->Small]]

Les deux sont égaux si la précision du cas exact a été dégradée au niveau du cas approché.

With[{c=(1.+I)/2},HL[Point@cartesian@c,Pi/2]==HL@Point@cartesian@c]

With[{c=.15+.05I,θ=1.},Graphics[{Circle[],Red,Blue,HL[Point@cartesian@c,θ]},PlotRange->square@1.5,ImageSize->Small]]

With[{c=.15+.05I,θ=1.45},Graphics[{Circle[],Red,HL[Point@cartesian@c,0],Blue,HL[Point@cartesian@c,θ]},PlotRange->square@1.5,ImageSize->Small]]

With[{c=(1+I)/2},clip[{#,HL[#,0],Red,HL[#,0.05],Green,HL[#,3 Pi-0.02]},ImageSize->Small]&@Point@cartesian@c]

With[{c=.2+.05I},Manipulate[Graphics[{Circle[],Red,HL[Point@cartesian@c,0],Blue,HL[Point@cartesian@c,θ]},PlotRange->square@1.5,ImageSize->Small],{{θ,.439823},-Pi,2Pi}]]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))]},With[{θ=1. 10^-3},
Print@θ;Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5]&@HL[Point@pt,θ]]]]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))]},With[{θ=1. 10^-2},
Print@θ;Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5]&@HL[Point@pt,θ]]]]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))]},With[{θ=2 10^-2},
Print@θ;{Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5],#}&@HL[Point@pt,θ]]]]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))]},With[{θ=0},
Print@θ;{Graphics[{Circle[],Point@{0,0},Point@pt,#},ImageSize->Small,PlotRange->square@1.5],#}&@HL[Point@pt,θ]]]]

À faire : empêcher

HL[Point@{0,0},0]

Roue centrée à l'origine

Faisceau isotrope de n diamètres.  Si le cercle est divisé en nombre pair, alors superposition.

GraphicsGrid@{Graphics@Function[{n,c},Map[Line[cartesian/@{-#,#}]&,Normalize@c unitroots@n]][#,I]&/@Range@12}

Faisceau isotrope de 2n rayons.

GraphicsGrid@{Graphics@Function[{n,θ},Line/@Map[cartesian/@{0,#}&, E^(I θ) unitroots[2n]]][#,I]&/@Range@12}

Faisceau pseudo-isotrope de n diamètres (ce qui revient à appliquer un miroir à la moitié des demi-droites).

With[{n=5,θ=Pi/2},Take[unitroots[2n],n]]

With[{n=5,θ=Pi/2},{Graphics[#,ImageSize->Small],Short@#}&@Map[HL[Point@cartesian@#,0]&,E^(I θ)Take[unitroots[2n],n]]]

Clear@wheel;

wheel[n_Integer,θ_?NumericQ]:=Map[HL[Point@cartesian@#,0]&,E^(I θ)Take[unitroots[2n],n]]

GraphicsGrid@{Graphics@wheel[#,Pi/2]&/@Range@12}

With[{n=3,θ=Pi/2},wheel[n,θ]]

Roue hyperbolique

wheel[n_Integer,θ_?NumericQ,Point@pt_List]/;chop@pt=={0,0}:=wheel[n,θ]

Faisceau isotrope (modulo l'ordre dans Line) de n droites hyperboliques.

With[{n=5},Manipulate[With[{pt=cartesian[.2 E^(I ψ)]},Graphics[{Circle[],Composition[HL[Point@pt,#]&,Arg]/@Take[unitroots[2n],n]},ImageSize->Small,PlotRange->square@1.5]],{ψ,0,2Pi}]]

Orientation de la roue indépendante du centre de la roue.

With[{n=5},Manipulate[With[{pt=cartesian[.2E^(I ψ)]},Graphics[{Circle[],Composition[HL[Point@pt,#-Arg@complex@pt+θ]&,Arg]/@Take[unitroots[2n],n]},ImageSize->Small,PlotRange->square@1.5]],{ψ,0,2Pi},{θ,0,Pi}]]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))],p=4},With[{θ=Arg@complex@pt+p Pi/n+10^-(PrecisionGoal-4)/.precisions},Graphics[{Circle[],Composition[HL[Point@pt,#-Arg@complex@pt+θ]&,Arg]/@Take[unitroots[2n],n]},ImageSize->Small,PlotRange->square@1.5]]]]

Condition critique (invariante par rotation de Pi/n).

Mod[θ-Arg@complex@pt,Pi/n]==0

With[{n=5,θ=.0251327,u=.55},With[{pt=cartesian[E^(I θ) u]},HL[Point@pt,-Arg@complex@pt+θ]]]

wheel[n_Integer,θ_?NumericQ,Point@pt_List]:=
Composition[HL[Point@pt,#-Arg@complex@pt+θ]&,Arg]/@Take[unitroots[2n],n]

With[{n=5},Manipulate[With[{pt=cartesian[E^(I θ) u]},Grid@List@{clip[#,ImageSize->Small,Method->None,PlotRange->square@2],#}&@wheel[n,θ,Point@pt]],{{u,.55(*.556*)},0,1},{θ,-Pi,Pi}]]

With[{n=5},Animate[With[{pt=cartesian[.2E^(I θ)]},clip[{wheel[n,Pi/2,Point@pt]},Method->None,ImageSize->Small,PlotRange->square@1.5]],{θ,0,2Pi}]]

Point conjugués.  (Manipulate n'accepte pas Slider2D.)  À faire : contraindre la commande dans le disque unité.

DynamicModule[{pt={0,.6},θ=Pi/2},GraphicsGrid@{{Slider2D[Dynamic@pt,Transpose[{#,#}&@{-1,1}]],Slider[Dynamic@θ,{-Pi,Pi}]},{Dynamic@With[{n=6},Graphics[{Circle[],Red,Point@pt,wheel[n,θ,Point@pt]},PlotRange->square[(euclideannorm@pt)^-1]]],Dynamic@{pt,θ}}}]

With[{n=5},With[{pt=cartesian[.2E^(-I Pi/(2n))]},With[{θ=Arg@complex@pt+2Pi/n+10^-(PrecisionGoal-3)/.precisions},Graphics[{Circle[],wheel[n,θ,Point@pt]},ImageSize->Small,PlotRange->square@1.5]]]]

Réseau symétrique de droites hyperboliques

Génération

À partir de cercles et points, construire de nouveaux points et cercles par intersection, miroir, rotation.

With[{n=5,c=.304I},With[{HLpositions={{1,3},{2,1}},pointpositions={{1}}},{colorize@Append[#1,newHLs[#2,#3]],#4}&[#1,#2,Sequence@@{#,#}&@Join1[#4,newpoints[#2,#3]]]&[Sequence@@{#,Extract[#,HLpositions]}&[Last/@First@#],Sequence@@{Extract[#,pointpositions],#}&@Last@#]&@{{{Hue[0.1`],{Circle[{0,1.82`},1.52`],Circle[{-1.73`,0.56`},1.52`],Circle[{-1.07`,-1.47`},1.52`],Circle[{1.07`,-1.47`},1.52`],Circle[{1.73`,0.56`},1.52`]}},{Hue[0.2`],{Circle[{-0.86`,1.19`},1.08`],Circle[{-1.4000000000000001`,-0.45`},1.08`],Circle[{0,-1.47`},1.08`],Circle[{1.4000000000000001`,-0.45`},1.08`],Circle[{0.86`,1.19`},1.08`]}}},{Point[{-0.23`,0.32`}]}}]]

Ne pas reprendre tous les points pour le calcul des cercles.

Clear@newcirclegeneration;
newcirclegeneration[HLpositions_,pointpositions_,newpoints_,newHLs_]:={colorize@Append[#1,newHLs[#2,#3]],#4}&[#1,#2,Sequence@@Flatten[#,1]&@Outer[Join[#2,#1]&,{newpoints[#2,#3]},{#3,#4},1,1]]&[Sequence@@{#,Extract[#,HLpositions]}&[Last/@First@#],Sequence@@{Extract[#,pointpositions],#}&@Last@#]&

With[{n=5,c=.304I},With[{HLpositions={{1,3},{2,1}},pointpositions={{1}}},(newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]/.Join->Join1)@{{{Hue[0.1`],{Circle[{0,1.82`},1.52`],Circle[{-1.73`,0.56`},1.52`],Circle[{-1.07`,-1.47`},1.52`],Circle[{1.07`,-1.47`},1.52`],Circle[{1.73`,0.56`},1.52`]}},{Hue[0.2`],{Circle[{-0.86`,1.19`},1.08`],Circle[{-1.4000000000000001`,-0.45`},1.08`],Circle[{0,-1.47`},1.08`],Circle[{1.4000000000000001`,-0.45`},1.08`],Circle[{0.86`,1.19`},1.08`]}}},{Point[{-0.23`,0.32`}],Point[{1,2}]}}]]

Paramètre radial u

Génération 1

Orientation Arg@c.

With[{n=5,c=.3I},(Print@clip@#;#)&@rotateorbit[n,Arg@c]@HL@Point@cartesian@c]

Génération 2 : passe par intersection (1,diamètre) à calculer et miroir

With[{n=5,c=.304I},(Print@clip@#;#)&@With[{HLpositions={{-1,1},{-1,2}},pointpositions={},newpoints={Point@First[intersection@@#]}&,newHLs=rotateorbit[n,Arg@c]@HL@Point@First@Last@#2&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@{{{_,rotateorbit[n,Arg@c]@HL@Point@cartesian@c}},{}}]

Clear@nestHL;
nestHL[p_Integer][n_Integer,Point@pt_List]/;p>1:=Nest[With[{HLpositions={{-1,1},{-1,2}},pointpositions={},newpoints={Point@First[intersection@@#]}&,newHLs=rotateorbit[n,Arg@complex@pt]@HL@Point@only@Last@#2&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]],{{{_,rotateorbit[n,Arg@complex@pt]@HL@Point@pt}},{}},p-1]

With[{n=5,c=.3I,p=2},nestHL[p][n,Point@cartesian@c]]

roundall[2]@%

Les derniers cercles ne se coupent pas donc on ne peut pas continuer ainsi,

With[{p=3,n=5,c=.3I},(Print@clip[#,ImageSize->Small];#)&@nestHL[p][n,Point@cartesian@c]]

sauf en réduisant le paramètre, ce qui ne fait que repousser le problème un peu plus en profondeur.

With[{p=5,n=5,c=.2I},clip[{wheel[n,Arg@c],nestHL[p][n,Point@cartesian@c]},ImageSize->Small]]

On en reste donc là :

With[{p=2,n=5,c=.3I},Scan[Print,{clip@{wheel[n,Arg@c],#},colorlegend[p,ImageSize->Small],#}]&@nestHL[p][n,Point@cartesian@c]]

Paramètre angulaire θ

Générations 3 : passe par intersection (2,diamètre) à calculer

Nouveau principe de construction.

With[{n=5,c=.304I,θ=.75,p=2},(Print@clip@#;#)&@With[{HLpositions={{-1,1}},pointpositions={},newpoints={Point@First@intersection[only@#,Line@{{0,0},cartesian@c}]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrorHLs[Point@cartesian@#,θ]&,complex@only@Last@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@nestHL[p][n,Point@cartesian@c]]

Clear@circlegeneration;

With[{p=3},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=With[{HLpositions={{-1,1}},pointpositions={},newpoints={Point@First@intersection[only@#,Line@{{0,0},pt}]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrorHLs[Point@cartesian@#,θ]&,complex@only@Last@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@nestHL[p-1][n,Point@pt]]

With[{p=3,n=5,c=.304I,θ=.75},(Print@clip[{wheel[n,Arg@c],#},Method->Circle];#)&@circlegeneration[p][n,cartesian@c,θ]]

With[{p=3,n=5},Manipulate[With[{c=Normalize[.2+I] u},Graphics[{Circle[],wheel[n,Arg@c],circlegeneration[p][n,cartesian@c,θ]},PlotRange->enveloprotate[{{-1.2,.1},{-1.2,1.2}},Arg@c-Pi/2]]],{{u,.304},.2,.4},{{θ,.75},0,Pi/2}]]

colorlegend[3,ImageSize->Tiny]

Génération 4 : passe par intersection (1,3) à calculer et intersection (3,diamètre) à calculer

With[{p=3,n=5,c=.304I,θ=.75},(Print@clip@{wheel[n,Arg@c][[4]],#};#)&@With[{oldcirclegeneration=circlegeneration[p][n,cartesian@c,θ]},extractfromcolorized[First@oldcirclegeneration,{{1,3},{3,1,2},{3,2,1}}]]]

1.Last@Last@wheel[5,Pi/2][[4]]

1.cartesian[I Part[unitroots@5,-1]]

With[{p=3,n=5,c=.304I,θ=.75},(Print@clip@#;#)&@With[{pt1=Last@only@wheel[n,Arg@c][[4]]},With[{HLpositions={{1,3},{3,1,2},{3,2,1}},pointpositions={},newpoints={Point@First[intersection@@Most@#],Point@First[intersection[Last@#,Line@{{0,0},pt1}1]]}&,newHLs=
Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrororbit[Arg@complex@pt1],HL@@Take[#2,-2]&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ]]]

With[{p=4},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=With[{pt1=Last@only@wheel[n,Arg@complex@pt][[4]]},With[{HLpositions={{1,3},{3,1,2},{3,2,1}},pointpositions={},newpoints={Point@First[intersection@@Most@#],Point@First[intersection[Last@#,Line@{{0,0},pt1}]]}&,newHLs=
Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit[Arg@complex@pt1],HL@@Take[#2,-2]&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]]

With[{p=4,n=5,c=.3I,θ=.75},(Print@clip@#;#)&@circlegeneration[p][n,cartesian@c,θ]]

With[{p=4,n=6,c=.3I,θ=.6},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Tiny]]

Faire passer l'intersection 1, 3, 4 par l'axe transverse (orthogonal à c).

With[{p=4,n=5,c=.3I},Manipulate[clip[circlegeneration[p][n,cartesian@c,θ],Axes->True,PlotRange->enveloprotate[{{-1,.0},{-.5,.3}},Arg@c-Pi/2]],{{θ,.75},.7,.9}]]

With[{p=4,n=5,c=.3I,θ=.75},clip[extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{1,3},{3,1,2}}],Axes->True,ImageSize->Small]]

With[{p=4,n=5,c=.3I,θ=.75},Last@First[intersection@@Extract[Last/@First@circlegeneration[p][n,cartesian@c,θ],{{1,3},{3,1,2}}]]]

With[{p=4,n=5,c=.3I},Block[{θ},Column@{{θ},Graphics[{circlegeneration[p][n,cartesian@c,θ]},Axes->True,PlotRange->enveloprotate[{{-.7,-.68},{-.01,.01}},Arg@c-Pi/2]]}/.FindRoot[Last@First[intersection@@Extract[Last/@First@circlegeneration[4][n,cartesian@c,θ],{{1,3},{3,1,2}}]],{θ,.75},Evaluated->False]]]

Invariance par rotation autour de l'origine.

clip[With[{p=4,n=5,c=.3E^(I (Pi/2+.2))},Block[{θ},circlegeneration[p][n,cartesian@c,θ]/.FindRoot[First@pointrotate[First[intersection@@Extract[Last/@First@circlegeneration[4][n,cartesian@c,θ],{{1,3},{3,1,2}}]],-Arg@c],{θ,.75},Evaluated->False]]]]

With[{p=4,n=5,c=.3035I},Block[{θ},FindRoot[First@pointrotate[First[intersection@@Extract[Last/@First@circlegeneration[p][n,cartesian@c,θ],{{1,3},{3,1,2}}]],-Arg@c],{θ,.75},Evaluated->False]]]

Particulier à n=5 donc préférer la version précédente.

With[{p=4,n=5},circlegeneration[p][n,pt_List,Automatic]:=(*chop@*)Block[{θ},circlegeneration[p][n,pt,θ]/.FindRoot[First@pointrotate[First[intersection@@Extract[Last/@First@circlegeneration[p][n,pt,θ],{{1,3},{3,1,2}}]],-Arg@complex@pt],{θ,.75},Evaluate[Sequence@@precisions],Evaluated->False]]]

With[{p=4,n=5,θ=Automatic},Manipulate[With[{c=.3035I E^(I ψ)},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Small]],{ψ,0,Pi/2}]]

With[{p=4,n=5,c=.3035I,θ=Automatic},circlegeneration[p][n,cartesian@c,θ]]

With[{p=4,n=5,c=.3035I,θ=.7489},circlegeneration[p][n,cartesian@c,θ]]

clip@{%,%%}

With[{p=4,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip@{wheel[n,Arg@c],#},colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Génération 5 : passe par intersection (2,4) à calculer et miroir

Scan[Print,{#,clip[#,ImageSize->Small]}]&@With[{p=4,n=5,c=.304I,θ=.75},{extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{2,-1},{4,1,1}}]}]

Scan[Print,{#,clip[#,ImageSize->Small]}]&@With[{p=4,n=5,c=.304I,θ=.75},{extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{2,1},{4,-1,2}}]}]

On ne garde qu'un point, puisque l'autre est en miroir.  À faire : miroir pour simplifier.

With[{p=4,n=5,c=.304I,θ=.75},(Print@clip@#;#)&@MapAt[Delete[#,-2]&,#,-1]&@With[{HLpositions={{2,-1},{4,1,1},{2,1},{4,-1,2}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=rotateorbit[n,Arg@c][HL@@Take[#2,-2]]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ]]

With[{p=5},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=MapAt[Delete[#,-2]&,#,-1]&@With[{HLpositions={{2,-1},{4,1,1},{2,1},{4,-1,2}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=rotateorbit[n,Arg@complex@pt][HL@@Take[#2,-2]]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=5,n=6,c=.3I,θ=.4},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Tiny]]

With[{p=5,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip@{wheel[n,Arg@c],#},colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Génération 6 : passe par intersection (1,3) connue et intersection (5,diamètre) à calculer

With[{p=5,n=5,c=.304I,θ=.75},clip[extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{-1,1}}],ImageSize->Small]]

On ne garde pas le nouveau point, image par rotation d'un ancien.

With[{p=6},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=MapAt[Most,#,-1]&@With[{HLpositions={{-1,1}},pointpositions={{3}},newpoints={Point@First@intersection[only@#1,Line@{{0,0},pt}],Point@pointrotate[only@only@#2,- 2Pi/5]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@Take[#2,-2]&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=6,n=6,c=.3E^(I (Pi/2+.4)),θ=.5},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Tiny]]

With[{p=6,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip@{wheel[n,Arg@c],#},colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Génération 7 : passe par intersection (2,4) connue et intersection (3, 4) à calculer

With[{p=6,n=5,c=.3035I,θ=0.7489},Graphics[{Circle[],wheel[n,Arg@c],circlegeneration[p][n,cartesian@c,θ]},PlotRange->enveloprotate[{{-.5,0.1},{.5,1}},Arg@c-Pi/2],ImageSize->Small]]

With[{p=6,n=5,c=.3035I,θ=0.7489},clip[extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{3,-1,2},{4,1,2}}],PlotRange->enveloprotate[{{-.5,0.1},{.5,1}},Arg@c-Pi/2],ImageSize->Small]]

With[{p=6,n=5,c=.3035I,θ=.7489},(Print@clip@#;#)&@With[{HLpositions={{3,-1,2},{4,1,2}},pointpositions={{-2}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrororbit@Arg@c,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ]]

With[{p=7},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=With[{HLpositions={{3,-1,2},{4,1,2}},pointpositions={{-2}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=7,n=5,c=.3035I,θ=0.7489},(Print@clip@#;#)&@circlegeneration[p][n,cartesian@c,θ]]

With[{p=7,n=6,c=.304E^(I (Pi/2+.2)),θ=.4},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Tiny]]

With[{p=7,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip@{wheel[n,Arg@c],#},colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Génération 8 : passe par intersection (3,6) à calculer et miroir

With[{p=7,n=5,c=.304I,θ=0.7489},(Print@clip[{wheel[n,Arg@c],#},ImageSize->Small];#)&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{3,1,2},{6,1,1}}]]

With[{p=7,n=5,c=.304I,θ=0.7489},(Print@clip[{wheel[n,Arg@c],#},ImageSize->Small];#)&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{3,1,1},{6,1,2}}]]

With[{p=7,n=5,c=.3035I,θ=.7489},(Print@clip@{wheel[n,Arg@c],#};#)&@MapAt[Delete[#,-2]&,#,-1]&@With[{HLpositions={{3,1,2},{6,1,1},{3,1,1},{6,1,2}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=rotateorbit[n,Arg@c][HL@@Take[#2,-2]]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ]]

With[{p=8,n=6,pt=cartesian[.2I E^(I.1)],θ=.6,θ1=.2},MapAt[Delete[#,-2]&,#,-1]&@With[{HLpositions={{3,1,2},{6,1,1},{3,1,1},{6,1,2}},pointpositions={},newpoints={Point@First1[intersection@@Take[#,-2]],Point@First1[intersection2@@Take[#,2]]}&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=8},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=MapAt[Delete[#,-2]&,#,-1]&@With[{HLpositions={{3,1,2},{6,1,1},{3,1,1},{6,1,2}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=rotateorbit[n,Arg@complex@pt][HL@@Take[#2,-2]]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=8,n=6,c=.2I,θ=.4},clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Small]]

With[{p=8,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip@{wheel[n,Arg@c],#},colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Génération 9 : passe par intersection (3,6) connue et intersection (3,4) connue

With[{p=8,n=5,c=.3035I,θ=.7489},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-1,0},{0,1}},Arg@c-Pi/2]],colorlegend@p}]&@With[{HLpositions={},pointpositions={{-2},{-1}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrororbit@Arg@c,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ]]

With[{p=9},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ]:=With[{HLpositions={},pointpositions={{-2},{-1}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=9,n=7 },Manipulate[With[{c=u E^(I (Pi/2+.4)) },clip[circlegeneration[p][n,cartesian@c,θ],ImageSize->Small]],{{u,.23},.1,.8},{{θ,.6},.1,.9}]]

With[{p=9,n=5,c=.3035I,θ=0.7489},Scan[Print,{#,clip[{wheel[n,Arg@c],#}],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ]]

Paramètre angulaire θ1

Par symétrie, il reste trois points de croissance, chacun devant être complété par deux droites hyperboliques, à un ou deux paramètres angulaires.  On commence par le point de croissance sur le rayon Pi/10, parce que le miroir garantit un paramètre angulaire.

Génération 10 : passe par intersection (9,diamètre) à calculer

With[{p=9,n=5,c=.3035I,θ=.7489},(Print@clip[#,PlotRange->enveloprotate[{{-1,0},{0,1}},Arg@c-Pi/2],ImageSize->Tiny];#)&@{wheel[n,Arg@c][[2]],extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ],{{-1,1,1}}]}]

With[{p=9,n=5,c=.3035I,θ=.7489},Manipulate[clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-1,-.2},{.5,1}},Arg@c-Pi/2]]&@With[{HLpositions={{-1,1,1}},pointpositions={},newpoints={Point@First@intersection[only@#,Line@{{0,0},#}&@Last@only@wheel[n,Arg@c][[2]]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrorHLs[Point@cartesian@#,θ1]&,complex@only@Last@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ],{{θ1,.147},.1,.2}]]

With[{p=10},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{-1,1,1}},pointpositions={},newpoints={Point@First@intersection[only@#,Line@{{0,0},#}&@Last@only@wheel[n,Arg@complex@pt][[2]]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrorHLs[Point@cartesian@#,θ1]&,complex@only@Last@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ]]

With[{p=10,n=6,c=.2I E^(I.1),θ=.5,θ1=.2},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Small,PlotRange->square@.3],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=10,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-1,0},{0,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 11 : passe par intersection (3,10) à calculer et intersection (7,8) à calculer

With[{p=10,n=5,c=.3035I,θ=0.7489,θ1=.147},(Print@clip[{wheel[n,Arg@c],#},ImageSize->Small,PlotRange->enveloprotate[{{-.9,-.2},{.5,1}},Arg@c-Pi/2]];#)&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{3,1,2},{10,1,1}}]]

With[{p=10,n=5,c=.3035I,θ=0.7489,θ1=.147},(Print@clip[{wheel[n,Arg@c],#},ImageSize->Small,PlotRange->enveloprotate[{{-.9,-.2},{.5,1}},Arg@c-Pi/2]];#)&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{7,1,1},{8,1}}]]

With[{p=10,n=5,c=.3035I,θ=0.7489,θ1=.147},(Print@clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.1},{.5,1}},Arg@c-Pi/2]];#)&@With[{HLpositions={{3,1,2},{10,1,1},{7,1,1},{8,1}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=rotateorbit[n,Arg@c][HL@@Take[#2,-2]]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=11},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{3,1,2},{10,1,1},{7,1,1},{8,1}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@Take[#2,-2]&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=11,n=5,c=.3035I,θ=0.7489,θ1=.147},Graphics@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=11,n=6,c=.3I,θ=.6,θ1=.2},clip[circlegeneration[p][n,cartesian@c,θ,θ1],ImageSize->Small]]

With[{p=11,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 12 : passe par intersection (3,10) connue et intersection (6,10) à calculer

With[{p=11,n=5,c=.3035I,θ=0.7489,θ1=.147},(Print@clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.2},{.5,1}},Arg@c-Pi/2],ImageSize->Small];#)&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{6,1,1},{10,1,2}}]]

With[{p=11,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@With[{HLpositions={{6,1,1},{10,1,2}},pointpositions={{-1}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@c],mirrororbit@Arg@c,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=12},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{6,1,1},{10,1,2}},pointpositions={{-1}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=11,n=5,c=.3035I,θ=0.7489,θ1=.147},circlegeneration[p][n,cartesian@c,θ,θ1]]

clip[Last/@First@%]

With[{p=12,n=6,c=.2I E^(I.1),θ=0.5,θ1=.2},clip[circlegeneration[p][n,cartesian@c,θ,θ1],ImageSize->Small,PlotRange->square@.3]]

With[{p=12,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 13 : intersection (3,10) connue et intersection (3,4) connue

With[{p=13},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={},pointpositions={{-6},{-2}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=13,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.9,-.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 14 : intersection (2,4) connue et intersection (1,13) à calculer

With[{p=13,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Small]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{1,2},{13,1,1}}]]

With[{p=14},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{1,2},{13,1,1}},pointpositions={{5}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=14,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 15 : passe par intersection (5,13) à calculer et intersection (9,14) à calculer

À faire : mirroir hyperbolique.

With[{p=14,n=5,c=.3035 I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{5,1},{13,1,1},{9,1,1},{14,1,1}}]]

With[{p=15},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{5,1},{13,1,1},{9,1,1},{14,1,1}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@Take[#2,-2]&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=15,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#}],colorlegend@p}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=15,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 16 : passe par intersection (9,14) connue et intersection (3,11) à calculer

Mirroir hyperbolique 1.

With[{p=15,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{3,-1,2},{11,1,1}}]]

With[{p=16},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{3,-1,2},{11,1,1}},pointpositions={{-2}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=16,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 17 : passe par intersection (6,7) à calculer et intersection (14,diamètre) à calculer

Mirroir hyperbolique 1.  6 et 14 sont du même rouge.

With[{p=16,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Small]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{6,-1,2},{7,1,1}}]]

With[{p=16,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Small]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{14,1,1}}]]

With[{p=16,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{6,-1,2},{7,1,1},{14,1,1}}]]

With[{p=17},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{6,-1,2},{7,1,1},{14,1,1}},pointpositions={},newpoints={Point@First[intersection@@Most@#],Point@First[intersection[Last@#,Line@{{0,0},pt}]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=17,n=5,c=.3035I,θ=.7489,θ1=.147},(Scan[Print,{clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}];#)&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 18 : passe par intersection (5,13) connue et intersection (4,17) à calculer

Mirroir hyperbolique 9.

With[{p=17,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#,Point[{-0.22169754885286438`,0.9145858146888983`}]},ImageSize->Medium]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{5,1},{13,1,1}}]]

With[{p=17,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#}]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{4,1,1},{17,1,1}}]]

With[{p=18},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{4,1,1},{17,1,1}},pointpositions={{-4}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=18,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 19 : passe par intersection (1,14) connue et intersection (2,18) à calculer

Mirroir hyperbolique 9.

{Point[{-0.2338723717081037`,0.32189770411674823`}],Point[{0,0.5557238506262434`}],Point[{-0.7134435852718344`,-3.386519974080809`*^-6}],Point[{-0.6532296695149702`,-0.21224718578912596`}],Point[{-0.1413599610504776`,0.8242513547986146`}],Point[{0,0.7805204163430817`}],Point[{-0.32647642285665973`,0.7925288547355966`}],Point[{-0.42576543594515226`,0.7243110804153954`}],Point[{-0.5278314208933207`,0.7264976247741772`}],Point[{-0.39879240780906366`,0.8337937348954756`}],Point[{-0.4535343303677655`,0.8062753337135765`}],Point[{-0.5060829552932624`,0.7874886015303654`}],Point[{-0.2454745175769454`,0.8542101661841237`}],Point[{-0.2915894206574217`,0.8979206743302652`}],Point[{-0.22169754885286438`,0.9145858146888983`}],Point[{-0.37806521032641716`,0.8757792991931901`}],Point[{-0.07954084389958313`,0.9019056671716797`}],Point[{0,0.8970065479642043`}],Point[{-0.12438938553179835`,0.9377170250698166`}]}[[-7]]

With[{p=18,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#,Point[{-0.2454745175769454`,0.8542101661841237`}]},ImageSize->Medium]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{1,2},{14,1,1}}]]

With[{p=18,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#}]}]&@extractfromcolorized[First@circlegeneration[p][n,cartesian@c,θ,θ1],{{2,-1},{18,1,1}}]]

With[{p=19},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{2,-1},{18,1,1}},pointpositions={{-7}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=19,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.7,.1},{.5,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 20 : passe par intersection (7,8) connue et intersection (4,16) à calculer

Mirroir hyperbolique 9.  On pourrait regrouper avec 19 (même couleur).

With[{p=19,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Medium]}]&@{extractfromcolorized[First@#,{{7,1,1},{8,1},{4,1,2},{16,1,1}}],Extract[Last@#,{{-11}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=20},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{4,1,2},{16,1,1}},pointpositions={{-11}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=20,n=5,c=.3035I E^(I.2),θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#}],colorlegend@p}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=20,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.6,.05},{.6,1}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=20,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.3,.05},{.7,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 21 : passe par intersection (2,19) connue et intersection (7,17) connue

With[{p=20,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Medium]}]&@{extractfromcolorized[First@#,{{2,-1},{19,1,1},{7,1,1},{17,1}}],Extract[Last@#,{{-2},{-5}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=21},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={},pointpositions={{-2},{-5}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=21,n=5,c=.3035I E^(I.2),θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#}],colorlegend@p}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=21,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.6,.05},{.6,1}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=21,n=5,c=.3035I,θ=.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.7,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 22 : passe par intersection (7,17) à calculer et intersection (14,21) à calculer

With[{p=21,n=5,c=.3035I,θ=0.7489,θ1=.147},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.5,0},{.5,1}},Arg@c-Pi/2],ImageSize->Small]}]&@{extractfromcolorized[First@#,{{7,1,1},{17,-1,2},{14,-1,2},{21,1,1}}],Extract[Last@#,{}]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=22},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={{7,1,1},{17,-1,2},{14,-1,2},{21,1,1}},pointpositions={},newpoints={Point@First[intersection@@Take[#,-2]],Point@First[intersection@@Take[#,2]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

Réglage fin, tous les chiffres sont significatifs.

With[{p=22,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.8,1}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=22,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.7,1}},Arg@c-Pi/2]],colorlegend@p}]&@circlegeneration[p][n,cartesian@c,θ,θ1]]

Génération 23 : passe par intersection (4,17) connue et intersection (7,17) connue

With[{p=22,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,clip[{wheel[n,Arg@c],#},ImageSize->Small,PlotRange->enveloprotate[{{-.2,.05},{.7,1}},Arg@c-Pi/2]]}]&@{extractfromcolorized[First@#,{{4,1},{17,1,1},{7,1,1},{17,-1,2}}],Extract[Last@#,{{-5},{-1}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=23},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={},pointpositions={{-5},{-1}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=23,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.8,1}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=23,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.8,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&[circlegeneration[p][n,cartesian@c,θ,θ1]]]

Génération 24 : passe par intersection (14,21) connue et miroir

With[{p=23,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.2,.05},{.8,1}},Arg@c-Pi/2]]}]&@{extractfromcolorized[First@#,{{14,-1,2},{21,1,1}}],Extract[Last@#,{{-2}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=24},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ]:=With[{HLpositions={},pointpositions={{-2}},newpoints={Point@pointmirror[only@only@#2,Arg@complex@pt]}&,newHLs=rotateorbit[n,Arg@complex@pt][HL@@#2]&},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=24,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,Graphics[{Circle[],wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.5,1.05}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1]]]

With[{p=24,n=5,c=.30351I,θ=.7490,θ1=.148},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.6,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&[circlegeneration[p][n,cartesian@c,θ,θ1]]]

Encore deux paramètres

Génération 25 : passe par intersection (10,12) connue et un point arbitraire sur un diamètre

With[{p=24,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.6,1}},Arg@c-Pi/2]]}]&@{extractfromcolorized[First@#,{{10,1,2},{12,1,1}}],Extract[Last@#,{{12}}],Point[u1 Last@only@wheel[n,Arg@c][[2]]]}&@circlegeneration[p][n,cartesian@c,θ,θ1]]

With[{p=25},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ,u1_?NumericQ]:=With[{HLpositions={},pointpositions={{12}},newpoints={Point[u1 Last@only@wheel[n,Arg@complex@pt][[2]]]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1]]

With[{p=25,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955},circlegeneration[p][n,cartesian@c,θ,θ1,u1]]

With[{p=25,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955},Scan[Print,{Graphics[{Circle[],wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.6,1}},Arg@c-Pi/2]]}]&[Last/@First@circlegeneration[p][n,cartesian@c,θ,θ1,u1]]]

With[{p=25,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955},Scan[Print,{#,clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.6,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&[circlegeneration[p][n,cartesian@c,θ,θ1,u1]]]

Génération 26 : passe par intersection (4,17) connue et un point arbitraire sur 2

With[{p=25,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955},Manipulate[clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.65,.05},{.6,1}},Arg@c-Pi/2]]&@{extractfromcolorized[First@#,{{4,1,1},{17,1,1}}],{#,Point[First@#+Last@#cartesian[I E^(I θ2)]]}&@only@Extract[Last/@First@#,{{2,-1}}],Extract[Last@#,{{-7}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1,u1],{θ2,1.7,1.95}]&@circlegeneration[p][n,cartesian@c,θ,θ1,u1]]

With[{p=26},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ,u1_?NumericQ,θ2_?NumericQ]:=With[{HLpositions={{2,-1}},pointpositions={{-7}},newpoints={Point[First@#+Last@#cartesian[Normalize@complex@pt E^(I θ2)]]&@only@#1}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1,u1]]

With[{p=26,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955,θ2=1.79},Scan[Print,{clip[#],colorlegend[p,ImageSize->Large]}]&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

With[{p=26,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955,θ2=1.79},Scan[Print,{#,clip[#,PlotRange->enveloprotate[{{-.3,0},{.8,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

Génération 27 : passe par intersection (2,26) connue et intersection (5,13) connue

With[{p=26,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955,θ2=1.79},(Print@clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.3,0},{.8,1}},Arg@c-Pi/2]];#)&@{extractfromcolorized[First@#,{{2,-1},{5,1},{13,1,1}}],Extract[Last@#,{{-12},{-1}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

With[{p=27},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ,u1_?NumericQ,θ2_?NumericQ]:=With[{HLpositions={},pointpositions={{-12},{-1}},newpoints={}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1,u1,θ2]]

With[{p=27,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955,θ2=1.79},Scan[Print,{#,clip[#,PlotRange->enveloprotate[{{-.4,-.1},{.8,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

Génération 28 : passe par intersection (9,14) connue et intersection (1,27) à calculer

With[{p=27,n=5,c=.30351I,θ=.7490,θ1=.148,u1=.955,θ2=1.79},(Print@clip[{wheel[n,Arg@c],#},PlotRange->enveloprotate[{{-.4,-.1},{.8,1}},Arg@c-Pi/2]];#)&@{extractfromcolorized[First@#,{{1,2},{27,1,1},{9,1,1},{14,1,1}}],Extract[Last@#,{{-13}}]}&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

With[{p=28},circlegeneration[p][n_Integer,pt_List,θ_?NumericQ,θ1_?NumericQ,u1_?NumericQ,θ2_?NumericQ]:=With[{HLpositions={{1,2},{27,1,1}},pointpositions={{-13}},newpoints={Point@First[intersection@@#1]}&,newHLs=Composition[sortdet[#,First]&/@#&,Transpose,rotateorbit[n,Arg@complex@pt],mirrororbit@Arg@complex@pt,HL@@#2&]},newcirclegeneration[HLpositions,pointpositions,newpoints,newHLs]]@circlegeneration[p-1][n,pt,θ,θ1,u1,θ2]]

With[{p=28,n=5,c=.30351I E^(I.0),θ=.7490,θ1=.148,u1=.955,θ2=1.79},Scan[Print,{#,clip[#,PlotRange->enveloprotate[{{-.4,-.1},{.8,1}},Arg@c-Pi/2]],colorlegend[p,ImageSize->Large]}]&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]]

Synthèse

With[{p=28,n=5,c=.30351I E^(I.2),θ=.7490,θ1=.148,u1=.955,θ2=1.79},clip[{wheel[n,Arg@c],{Last/@First@#,PointSize@.01,Composition[rotateorbit[n,Arg@c],mirrororbit@Arg@c,Last]@#}&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]},ImageSize->Large]]

Export["Background.pdf",%]

With[{p=28,n=5,c=.30351I E^(I.0),θ=.7490,θ1=.148,u1=.955,θ2=1.79},clip[{wheel[n,Arg@c],{Last/@First@#,PointSize@.01,Composition[rotateorbit[n,Arg@c],mirrororbit@Arg@c,Last]@#}&@circlegeneration[p][n,cartesian@c,θ,θ1,u1,θ2]},Method->Circle,ImageSize->Large]]

Export["Circle.pdf",%]

Réseau symétrique de roues hyperboliques

Intersection externe en chaîne

Génération 1 : roues conjuguées

Orbite d'ordre n d'une roue d'ordre n.  Roues conjuguées = ayant un élément en commun.  Conjugaison possible pour un certain paramètre si n≥5.

À faire : montrer que le centre du plus grand cercle est sur le cercle à côté du diamètre.

With[{n=5},Manipulate[With[{c=E^(I θ)},Grid@Transpose@List@{clip[#,ImageSize->Medium,Method->None,PlotRange->{{-1.5,.2},{-.2,1.5}}],#}&@{#,PointSize->.01,Red,Point/@Extract[#,{{2,2,1}}],Green,Point/@Extract[#,{{-1,1,1}}]}&@rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[u Normalize@c]]],{{u,Switch[n,5,.58,6,.7,_,.8]},0,1},{{θ,Pi/2},0,Pi}]]

Recherche de racine.

With[{n=7,c=E^(I Pi/2)},FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,.7},Evaluate[Sequence@@precisions],Evaluated->False]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[# Normalize@c]]]]

Formule d'estimation empirique.

ListPlot[With[{n=#},{n,Block[{u},u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,.7},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@With[{c=I},wheel[n,Arg@c,Point@cartesian[# Normalize@c]]]]}]&/@Range[5,12],ImageSize->Medium]

{Block[{n},Fit[#,{1,(n^(-1)),(n^(-2))},n]],#}&[With[{n=#},{n,Block[{u},u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,.7},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@With[{c=I},wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]}]&/@Range[5,12]]

(Print@Show[Plot[#1,{n,#2[[1,1]],#2[[-1,1]]}],ListPlot@#2];#1)&[Block[{n},Fit[#,{1(*,(n^(-1))*),(n^(-2))},n]],#]&[With[{n=#},{n,Block[{u},u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,.7},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@With[{c=I},wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]}]&/@Range[5,10]]

Clear@estimate;
estimate@n_Integer:=1.02-(11.43/(n^2))

Show[Plot[estimate@Round@n+.015{-1,1},{n,#[[1,1]],#[[-1,1]]}],ListPlot@#,AxesOrigin->Automatic]&[With[{n=#},{n,Block[{u},u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,estimate@n},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@With[{c=I},wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]}]&/@Range[5,12]]

Clear@interval;interval[n_Integer,error_]:=Apply[Sequence,estimate@n+error{-1,1}]

With[{n=5,c=I},Block[{u},FindRoot[euclideandistance@@Extract[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[u Normalize@c]],{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]]

Enlever cercle en double avec Most.  Regrouper par roue.

Grid[List@With[{n=#,c=I},clip[#,ImageSize->Small]&@Most@Block[{u},Unevaluated[Print@u;#@u]/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]&/@Range[5,10]]

With[{n=5,c=I},(Print@clip[colorize@#,ImageSize->Medium];#)&@Take[#,n-1]&@Transpose@Most@Block[{u},Unevaluated[Print@u;#@u]/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Génération 2 : engrenage partiel minimal générateur

Engrenage = ensemble de roues.
Engrenage partiel = ensemble de parties de roues.

À partir de deux roues, on engendre une nouvelle roue, contenant un élément de chacune.
Dans un ensemble d'au moins deux roues, on groupe les roues par deux.

Sans perdre aucune roue nouvelle, on peut éliminer des roues ou des éléments de roue.  Avec l'invariance par rotation de 2Pi/n autour de l'origine, il suffit de deux roues consécutives circonférentiellement et, pour n impair, le diamètre de la (n+3)/2-ième roue, miroir engendrant une roue d'ordre 4, comprenant un grand cercle = de rayon maximal.

À faire : utiliser miroir pour n pair.

With[{n=5,c=I},Composition[clip[colorize@#,ImageSize->Medium,Axes->True]&,
(Print@#;#)&@If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&]@Transpose@Most@Block[{u},Unevaluated[Print@u;#@u]/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Points d'intersection nouveaux.

With[{n=5,c=I},Composition[clip[#,ImageSize->Small,Axes->False]&,
Outer[Composition[Point,First,intersection],Sequence@@#,1,1]&,If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&]@Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Roue centrée en chaque point d'intersection nouveau, incluant l'ensemble des intersécandes.

With[{n=7,c=I},Composition[
Outer[wheel1[fraction[#/Pi,If[OddQ@n,{4,n},{n}]]&@intersectionangle@##,tangent1[First@#1,#2],#2]&[{##},Point@First[intersection@##]]&,Sequence@@#,1,1]&,If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&]@Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

linefirst permet de se repérer à partir d'un diamètre (s'il en existe) pour extraire un élément de roue.  À faire : ordre canonique de roue.

Clear@outerintersection1;
outerintersection1@n_:=Transpose/@Outer[linefirst/@Transpose@rotateorbit[n]@wheel[fraction[#/Pi,If[OddQ@n,{4,n},{n}]]&@intersectionangle@##,Arg@complex@tangent[First@#1,#2],#2]&[{##},Point@First[intersection@##]]&,Sequence@@#,1,1]&

n impair : roue interne et roue externe.

With[{n=5,c=I},Composition[(Print@clip[colorize[#,2]&@Take[#,2]&@First@#,ImageSize->Medium,Axes->False];#)&,
outerintersection1@n,
If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&]@Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

n = 5 : une intersection semble sur l'axe transverse.  À faire : démontrer.

With[{n=5,c=I},Composition[(Print@clip[{#,If[n==5,HL[Point@cartesian[c I],0]]},ImageSize->Small,PlotRange->enveloprotate[{{-.5,.5},{.5,1}},Arg@c]];First[intersection@@Last/@#])&,
extractfromcolorized[#,If[n==5,{{2,1,3},{3,2,2}}]]&,
colorize@Flatten[#,1]&,
outerintersection1@n,
If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&,Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Pour continuer, il suffit de deux secteurs d'angle 2Pi/n consécutifs de génération 2, cette fois sans le diamètre de la (n+3)/2-ième roue, qui engendrerait une intersection non pointée sur le dessin original.  n≥8 pair : le nouveau point d'intersection est identitque à l'ancien (modulo rotation de 2Pi/n).

With[{n=5,c=I},Composition[(Print@clip[#,ImageSize->Medium];#)&,
colorize@Flatten[#,1]&,outerintersection1@n,If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&,Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Deux roues internes voisines n'engendrent aucune roue donc on peut éliminer l'une d'elle.  De plus, on peut éliminer des éléments de chaque roue.

With[{n=5,c=I},Composition[(Print@clip[#,ImageSize->Medium];#)&,
extractfromcolorized[#,{{-1},{1},{2,1,1}}]&,
colorize@Flatten[#,1]&,outerintersection1@n,If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&,Transpose@Most@Block[{u},Unevaluated@#@u/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Regrouper les droites hyperboliques en parties de roues.

Clear@minimal2;
minimal2[n_,θ_]:=MapAt[Composition[
Flatten[#,1]&@Outer[Extract[#1,#2]&,{#},#2,1,1]&[#,GatherBy[#,First]&@
If[
OddQ@n,{Sequence@@If[n==5,{{1,4},{1,5},{2,3}},{}],{2,-1},{2,-2},{3,2},{3,3}},
If[
n==6,{{1,-1},{2,3}},{}
]]]&,
Extract[#,Join[{{-1,1},{1,1}},If[OddQ@n,{{1,2}},{}]]]&,
Flatten[#,1]&,
outerintersection1@n,
If[OddQ@n,
{Extract[#,{{(n+3)/2,1}}],Extract[#,{{1,-1},{2,2}}]},
{Extract[#,{{2,3}}],Extract[#,{{1,-1}}]}
]&,Transpose,Most],Block[{u},{Unevaluated@#@u,{Point@cartesian[u E^(I θ)]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,θ,Point@cartesian[#E^(I θ)]]],1]

Manipulate[With[{n=5,c=E^(I(ψ+Pi/2))},clip[minimal2[n,Arg@c],ImageSize->Small]],{ψ,0,2Pi}]

n=5 : ∃ intersection non pointée sur le dessin original mais on ne peut pas l'éliminer sans éliminer aussi une intersection pointée sur le dessin original.
n≥7 impair : deux roues sont fertiles seulement si elle sont dans un même secteur.  
n≥8 pair : on ne peut pas continuer, le dessin est fini.

Grid[With[{n=#,c=I},{clip[{wheel[n,Arg@c],colorize@First@#,Last@#},ImageSize->Medium,Axes->False,If[n≥5,PlotRange->enveloprotate[{{0,1},{-1,1}},Arg@c],Sequence@@{}]],#}&@minimal2[n,Arg@c]]&/@{5,6,7,8,9}]

Génération 3 et généralisation

Fonctionne seulement avec exactement deux roues et des intersections non vides, ce qui n'est réalisé que pour n=6.

With[{n=6,c=I},(Print@clip[colorize@#,ImageSize->Medium,Axes->False];#)&@outerintersection1[n]@First@minimal2[n,Arg@c]]

Généraliser.  Éliminer intersection entre deux droites hyperboliques d'une même roue.

Subsets[#,{2}]&[{{c11,c12,c21},{c21,c23,c24},{c31,c32}}]

Éliminer intersection d'une droite hyperbolique avec elle-même.

Composition[f1,apart@@#&]/@Subsets[#,{2}]&[{{c11,c12,c21},{c21,c23,c24},{c31,c32}}]

Préparer les couples d'intersécandes, sans distinction d'origine.

Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&[{{c11,Line@c12,c21},{c21,c23,c24},{c31,Line@c32}}]

Éliminer intersection de diamètres, qui donnent toujours l'origine, inutile.

Composition[intersection@@#&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&][{{c11,Line@c12,c21},{c21,c23,c24},{c31,Line@c32}}]

Calculer les points d'intersection en conservant les intersécandes.  ∃ intersection vide.

With[{n=5,c=I},(Print@clip[{colorize@#1,#2},ImageSize->Medium,PlotRange->enveloprotate[{{-1,1},{0,1}},Arg@c-Pi/2]];#3)&[colorize@#,Sequence@@{Composition[Point,Last]/@#,#}&@Composition[{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@#]&@First@minimal2[n,Arg@c]]

Éliminer couples d'intersection vide.  Conserver le point d'intersection à l'intérieur du cercle unité (unique à cause du 1er postulat d'Euclide).  Conserver anciens points d'intersection.

With[{n=5,c=I},(Print@clip[{PointSize->.015,#1,Red,#2},ImageSize->Medium,PlotRange->enveloprotate[{{-1,1},{0,1}},Arg@c-Pi/2]];{##})&[Composition[MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@First@#,Last@#]&@minimal2[n,Arg@c]]

Éliminer les nouveaux points d'intersection identiques à un ancien (modulo rotation de 2Pi/n).  λ-calcul : fonction partielle => un symbole.

With[{n=5,c=I},(Print@clip[{PointSize->.015,#},ImageSize->Medium,PlotRange->enveloprotate[{{-1,1},{0,1}},Arg@c-Pi/2]];#)&@Select[Composition[MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@First@#,Function[cpp,MatchQ[Intersection[rotateorbit[n]@Last@cpp,#,SameTest->sametest],{}]]&@Last@#]&@minimal2[n,Arg@c]]

λ-calcul : intersectionpoints permet d'éliminer cpp.

With[{n=5,c=I},(Print@clip[{PointSize->.015,#},ImageSize->Medium,PlotRange->enveloprotate[{{-1,1},{0,1}},Arg@c-Pi/2]];#)&@With[{intersectionpoints=Last@#},Select[Composition[MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@First@#,MatchQ[Intersection[rotateorbit[n]@Last@#,intersectionpoints,SameTest->sametest],{}]&]]&@minimal2[n,Arg@c]]

Utile pour point triple : les angles sont quantifiés donc le même point ne peut apparaître comme centre de roues différentes donc on peut conserver une seule intersection par point, sans perdre aucune roue.  Regrouper les nouveaux points d'intersection avec les anciens.

With[{n=5,c=I},Function[{HLsets,intersectionpoints},f2[#1,Join[intersectionpoints,#2]]&@@Transpose[{intersectionangle1[#1,#2],#2}&@@#&/@Union[#,SameTest->Function@sametest[Last@#1,Last@#2]]]&@Select[Composition[MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@HLsets,MatchQ[Intersection[rotateorbit[5]@Last@#,intersectionpoints,SameTest->sametest],{}]&]]@@minimal2[n,Arg@c]]

Bon angle = multiple de  de Pi/4 ou Pi/n.
n=5 : droites hyperboliques qui n'existent pas sur la figure originale et vont engendrer des intersections avec un mauvais angle.
n=6 : OK.
n=7 : intersection tangentielle au bord.
n=8 : erreur de transposition de liste vide.

With[{n=6,c=I},With[{HLsets=First@#,intersectionpoints=Last@#},(Print@clip@{wheel[n,Arg@c],Take[#,2]&@colorize[#,2]&@First@#,Last@#};#)&@Composition[
{Transpose@#,Join[intersectionpoints,#2]}&@@#&,Transpose[{Transpose@rotateorbit[n]@wheel[fraction[#/Pi,If[OddQ@n,{4,n},{n}]]&@intersectionangle@##,Arg@complex@tangent[First@#1,#2],#2],#2}&@@#&/@#]&@Union[#,SameTest->Function@sametest[Last@#1,Last@#2]]&,Select[#,MatchQ[Intersection[rotateorbit[n]@Last@#,intersectionpoints,SameTest->sametest],{}]&]&,MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@HLsets]&@minimal2[n,Arg@c]]

With[{n=8,c=I},With[{HLsets=First@#,intersectionpoints=Last@#},Catch@Composition[
{Transpose@#,Join[intersectionpoints,#2]}&@@#&,Switch[#,{},Throw@outerintersection[n,{},intersectionpoints],_,Transpose@#]&[{Transpose@rotateorbit[n]@wheel[#3,Arg@complex@tangent[First@#1,#2],#2],#2}&@@#&/@DeleteCases[#,{___,_only}]&[{##,fraction[#/Pi,If[OddQ@n,{4,n},{n}]]&@intersectionangle@##}&@@#&/@#]]&,
Union[#,SameTest->Function@sametest[Last@#1,Last@#2]]&,Select[#,MatchQ[Intersection[rotateorbit[n]@Last@#,intersectionpoints,SameTest->sametest],{}]&]&,MapAt[Composition[Point,First],#,-1]&/@DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,apart@@#&]/@Subsets[#,{2}],1]&]@HLsets]&@minimal2[n,Arg@c]]

La structure de sortie a un niveau en plus de la structure d'entrée : le niveau orbital.

ClearAll@outerintersection;

outerintersection::usage="outerintersection[n,HLsets,intersectionpoints] orbit of the gearing obtained by intersecting HLs sets";

(*outerintersection::transpose="list not tranposable in outerintersection"*)

outerintersection[n_Integer,HLsets:{{(_Circle|_Line)..}..},intersectionpoints_List]:=Catch@Composition[
{Transpose@#,Join[intersectionpoints,#2]}&@@#&,Switch[#,{},(*n'aucune nouvelle intersection \[Implies] orbite vide*)Throw@outerintersection[n,{},intersectionpoints],_,(*regroupe roues engendrées sans rotation*)Transpose@#]&[{Transpose@rotateorbit[n]@wheel[#3,Arg@complex@tangent[First@#1,#2],#2],#2}&@@#&/@(*élimine angle non reconnu*)DeleteCases[#,{___,_only}]&[{##,fraction[#/Pi,If[OddQ@n,{4,n},{n}]]&@intersectionangle@##}&@@#&/@#]]&,
(*élimine point d'intersection en double*)Union[#,SameTest->Function@sametest[Last@#1,Last@#2]]&,(*élimine point d'intersection ancien*)Select[#,MatchQ[Intersection[rotateorbit[n]@Last@#,intersectionpoints,SameTest->sametest],{}]&]&,MapAt[Composition[Point,First],#,-1]&/@(*élimine vide*)DeleteCases[#1,{___,{}}]&,{#,intersection@@#}&/@(*élimine origine*)DeleteCases[#,{_Line,_Line}]&,Flatten[Composition[Distribute[#,List]&,(*élimine auto-intersection*)apart@@#&]/@Subsets[#,{2}],1]&]@HLsets

outerintersection[n_Integer,{},intersectionpoints_List]:={Table[{},{n}],intersectionpoints}

With[{n=8,c=I},With[{HLsets=First@#,intersectionpoints=Last@#},outerintersection[n,HLsets,intersectionpoints]]&@minimal2[n,Arg@c]]

With[{n=7,c=I},With[{HLsets=First@#,intersectionpoints=Last@#},(Print@clip@{wheel[n,Arg@c],Take[#,2]&@colorize[#,2]&@First@#,Last@#};#;)&@outerintersection[n,HLsets,intersectionpoints]]&@minimal2[n,Arg@c]]

With[{n=5,c=I},With[{HLsets=First@#,intersectionpoints=Last@#},(Print@clip@{wheel[n,Arg@c],Take[#,2]&@colorize[#,2]&@First@#,Last@#};#;)&@outerintersection[n,HLsets,intersectionpoints]]&@minimal2[n,Arg@c]]

Orbite initiale, chaque engrenage sectoriel étant composé d'une seule roue.

With[{n=5,c=I},Composition[(Print@clip@#;#)&,Block[{u},Unevaluated@{Composition[List/@#&,Transpose,Most]@#@u,{Point@cartesian[u Normalize@c]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Toute l'orbite d'engrenages est dessinée mais seulement deux éléments consécutifs sont nécessaires et suffisants pour continuer (sauf n impair et génération 2, cas où on utilise en plus le diamètre de la (n+3)/2-ième roue).

With[{n=5,c=I},Composition[(Print@clip[{colorize@First@#,Last@#}];#)&,MapAt[Flatten[#,1]&@Join[Take[#,2],If[OddQ@n,{{{#[[(n+3)/2,1,1]]}}},{}]]&,#,1]&,Block[{u},Unevaluated@{Composition[List/@#&,Transpose,Most]@#@u,{Point@cartesian[u Normalize@c]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Plus directement mais moins uniformément :

With[{n=5,c=I},Block[{u},Unevaluated@{Composition[Join[Take[#,2],If[OddQ@n,{{#[[(n+3)/2,1]]}},{}]]&,Transpose,Most]@#@u,{Point@cartesian[u Normalize@c]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]]

Suite périodique d'opérations, commençant par une exception si n impair.

With[{p=5},TableForm@Switch[p,0,{},_,Flatten@{MapAt[Composition[Flatten[#,1]&,Join[Take[#,2],If[OddQ@n,{{{#[[(n+3)/2,1,1]]}}},{}]]&],#,1]&,If[OddQ@p,#,Most@#]&@Flatten@Table[{outerintersection[n,Sequence@@#]&,MapAt[Composition[Flatten[#,1]&,Take[#,2]&],#,1]&
},{Floor[p/2]}]}]]

With[{p=3/2},TableForm@Switch[p,0,{},_,Flatten@{MapAt[Composition[Flatten[#,1]&,Join[Take[#,2],If[OddQ@n,{{{#[[(n+3)/2,1,1]]}}},{}]]&],#,1]&,Switch[p,_Integer,Most@#,_,#]&@Flatten@Table[{outerintersection[n,Sequence@@#]&,MapAt[Composition[Flatten[#,1]&,Take[#,2]&],#,1]&
},{p}]}]]

With[{p=5/2},TableForm@Switch[p,1,{},_,Flatten@{MapAt[Composition[Flatten[#,1]&,Join[Take[#,2],If[OddQ@n,{{{#[[(n+3)/2,1,1]]}}},{}]]&],#,1]&,Switch[p,_Integer,Most@#,_,#]&@Flatten@Table[{outerintersection[n,Sequence@@#]&,MapAt[Composition[Flatten[#,1]&,Take[#,2]&],#,1]&
},{p-1}]}]]

n pair : ∃ point fixe et toutes les intersections ont un bon angle.  Encadrement plus fiable que Newton (si l'encadrement initial est bon).

Manipulate[With[{n=5,c=E^(I (ψ+Pi/2))},Composition[Grid@{{clip[{colorize@First@#,Last@#},ImageSize->Medium]},{"génération "<>ToString@IntegerPart@p}}&,Sequence@@Reverse@Switch[p,1,{},_,Flatten@{MapAt[Composition[Flatten[#,1]&,Join[Take[#,2],If[OddQ@n,{{{#[[(n+3)/2,1,1]]}}},{}]]&],#,1]&,Switch[p,_Integer,Most@#,_,#]&@Flatten@Table[{outerintersection[n,Sequence@@#]&,MapAt[Composition[Flatten[#,1]&,Take[#,2]&],#,1]&
},{p-1}]}],Block[{u},Unevaluated@{Composition[List/@#&,Transpose,Most]@#@u,{Point@cartesian[u Normalize@c]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&]@Function[rotateorbit[n]@wheel[n,Arg@c,Point@cartesian[#Normalize@c]]]],{p,1,6,1/2},{ψ,0,2Pi}]

Histoire

Dater les droites hyperboliques.  Pour une intersection avec un mauvais angle, éliminer l'intersécande le plus récent.

Clear@wheelgeneration;With[{p=1},
wheelgeneration[p][n_,ψ_]:={#,p}&@MapAt[Map[{#,p}&,#,{3}]&,#,1]&@Block[{u},Unevaluated@{Composition[List/@#&,Transpose,Most]@#@u,{Point@cartesian[u E^(I ψ)]}}/.FindRoot[euclideandistance@@Extract[#@u,{{2,2,1},{-1,1,1}}],{u,interval[n,.015]},Evaluate[Sequence@@precisions],Evaluated->False]]&@Function[rotateorbit[n]@wheel[n,ψ,Point@cartesian[#E^(I ψ)]]]]

With[{n=5,p=1,ψ=0},wheelgeneration[p][n,ψ]]

wheelgeneration[p_][n_,ψ_]/;p>1:=Composition[{#,p}&,union1[outerintersection2[n,#],#]&,MapAt[Composition[Flatten[#,1]&,Join[Take[#,2],If[OddQ@n&&p==2,{{{#[[(n+3)/2,1,1]]}}},{}]]&],#,1]&,First]@wheelgeneration[p-1][n,ψ]

With[{n=5,p=2,ψ=0},wheelgeneration[p][n,ψ]]

Conclusion

Outils

Règle.  Équerre.  Compas.  Rapporteur.  Miroir.  Diviseur de cercle.

?"Global`*point*"

?"Global`*rotate*"

?"Global`*mirror*"

?"Global`*hyperbolic*"

?"Global`*intersection*"

?"Global`*circle*"

Utilisation

Reverse engineering

FindSequenceFunction[{1,1,2,3,5,8,13}]

Et la théorie ?

Quelques thorèmes à démontrer.

Utiliser métrique, calculer à priori la position ou la distance ou centre des nœuds.  Réseau homogène ?

Interprétation comme diagramme de Venn.

n=4 : rotation de 2Pi/4 d'une roue d'ordre 5, amorce du dessin dans Soury (Thomé), t. 3, 129.

With[{n=4,c=I},Manipulate[{clip[#,ImageSize->Small,Method->Circle],#}&@rotateorbit[n,Arg@c]@wheel[n+1,Arg@c,Point@cartesian[u Normalize@c]],{{u,.4},0,1}]]

Théorème de conjugaison.  
Conjugaison complexe : c -> 1/Conjugate@c.
Transformation conforme.
Puissance d'un point par rapport à un cercle.

Fractal ?

Autodual : les normales aux côtés des cellules sont dans le réseau.  

Empilement. Carrés à cheval sur pentagones ou pentagones à cheval sur carrés avec dislocations.  Plus simple d'empiler des pentagones, parce que pas de dislocation.

Œufologie du Pr. Shadoko.

Méthode

λ-calcul

Éliminer variables et constantes sans valeur sémantique.   Ne jamais recopier mais centraliser et distribuer dans flot de calcul.

{f1@#,#}&
Outer
Distribute

Gérer lexique.

?"Global`*"

Expliciter syntaxe.

circleintersection[___]->intersection[Circle[___],___]

Nettoyage logique => refactoring.  Conserver expression paramétrique.

With[{x=2,y=3},f1[x,y]]
With[{x=2,y=Pi},f1[x,y]]

Définition avec fonction pure et signature comme documentation minimale :

(f1=f2)->(Clear@f1;f1@[x___]:=f2@x)

Debug : bloquer évaluation en changeant nom de bloc fonctionnel.

(*unix tee*)(Print@#;#)&

Découpage avec Composition.

Plan

Minimiser bla-bla quasiment impossible à maintenir.  Travailler plutôt sur le plan.

Évaluer le cahier sans initialisation pour détecter références en avant et refaire le plan jusqu'à ce qu'il n'y ait plus de référence en avant.  Idéalement, le cahier doit s'exécuter sans erreur.

Va-et-vient entre outils et utilisation (cycle de développement).

Mathematica

Unité d'action : un seul cahier et .m généré automatiquement.  Unité perdue si écriture dans .m.  Un seul document multiéchelle grâce au plan.

Refactoring : NotebookFind ne reconnaît pas les expressions régulières.  Travail avec Emacs dans .m (lecture seulement), mode Emacs ?

Sélection d'une partie d'un graphique (existe dans matlab).

diff, gestion de version.

Calcul numérique

Précision numérique marginale : maîtriser la précision (chop), répondre plutôt une bêtise que rien (pour information), rendre les cas attractifs.  Les erreurs sont inévitables quand on balaye tout un domaine avec Manipulate.  Les zones marginales ne doivent pas être utilisées.

Compilation, interface (intersection), implémentation (lineintersection).

Typage

Le typage s'oppose à la généralité du calcul symbolique.

On peut en mettre plus ou moins.  Faut-il bétonner ?

HL[Point@pt_,___]\[Implies]
(Circle[pt,r]->circle[Point@pt_,r__])

Rule of thumb : ne jamais détyper, pour cela, typer en entrée, ne pas typer en sortie.

Comment ne pas avoir à modifier les fonctions quand la structure de données change ?  Roman Mæder Computer Science with Mathematic, ch. abstract data structure.  Programmation orientée vers les objets.
extractfromcolorized est un accesseur.

Épilogue

(*End[]
EndPackage[]*)